;; The MIU system in BlooP
;;
;; Written by Jim Marshall, spring 2016
;;
;; To run this code, first open interpreter.scm in DrRacket and type (start).
;; Then try the following commands at the interpreter prompt (==>):
;;
;; (load-quietly "miu-system-bloop.txt")
;; (rule1 31)
;; (rule2 31)
;; (rule3 31)
;; (rule3 3111111)
;; (rule4 30010001)
;; (apply-rules 31111)
;; (valid-step? 31 311)
;; (miu-proof-pair? 313113110 3110)
;; (miu-proof-pair? 30300 300)
;; (miu-proof-pair? 3131131111311110310031 31)

;;-------------------------------------------------------------------------

(define procedure "count-digits" (n)
  (block 0 begin
	 ((cell 0) <= n)
	 (output <= 1)
	 (loop at most n times
	       (block 1 begin
		      (if ((cell 0) < 10) then
			  (quit block 0))
		      ((cell 0) <= (quotient (cell 0) 10))
		      (output <= (output + 1))))))

(define procedure "last-digit" (n)
  (block 0 begin
	 (output <= (remainder n 10))))

(define procedure "first-digit" (n)
  (block 0 begin
	 (output <= (quotient n (power 10 (minus (count-digits n) 1))))))

(define procedure "remove-first-digit" (n)
  (block 0 begin
	 (output <= (remainder n (power 10 (minus (count-digits n) 1))))))

(define procedure "rule1" (n)
  (block 0 begin
	 (if (not ((last-digit n) = 1)) then
	     (quit block 0))
	 ((cell 0) <= (n * 10))
	 (print (cell 0))
	 (output <= 1)))

(define procedure "rule2" (n)
  (block 0 begin
	 (if ((not ((first-digit n) = 3)) or ((count-digits n) < 2)) then
	     (quit block 0))
	 ((cell 0) <= (n * (power 10 (minus (count-digits n) 1))))
	 ((cell 0) <= ((cell 0) + (remove-first-digit n)))
	 (print (cell 0))
	 (output <= 1)))

;; left and right are 0-based digit positions, least significant position = 0
(define procedure "get-digits" (n left right)
  (block 0 begin
	 (n <= (remainder n (power 10 (left + 1))))  ;; chop off everything before left
	 (output <= (quotient n (power 10 right))))) ;; chop off everything after right

(define procedure "get-digit" (n position)
  (block 0 begin
	 (output <= (get-digits n position position))))

;; replaces a 111 block with 0
;; n = 9871113210  => 98703210
;;          ^ right = 4  (least significant digit position = 0)
(define procedure "replace-iii" (n right)
  (block 0 begin
	 (output <= (quotient n (power 10 (right + 3))))         ;; all digits to left of iii block
	 (output <= (output * (power 10 (right + 1))))           ;; insert 0
	 (output <= (output + (remainder n (power 10 right)))))) ;; all digits to right of iii block

(define procedure "rule3" (n)
  (block 0 begin
	 (if ((count-digits n) < 3) then
	     (quit block 0))
	 (output <= 0)
	 ((cell 0) <= 0) ;; right position
	 (loop (minus (count-digits n) 2) times
	       (block 1 begin
		      (if ((get-digits n ((cell 0) + 2) (cell 0)) = 111) then
			  (block 2 begin
				 (print (replace-iii n (cell 0)))
				 (output <= (output + 1))))
		      ((cell 0) <= ((cell 0) + 1))))))

;; drops a 00 block
;; n = 9876003210  => 98763210
;;          ^ right = 4  (least significant digit position = 0)
(define procedure "drop-uu" (n right)
  (block 0 begin
	 (output <= (quotient n (power 10 (right + 2))))         ;; all digits to left of uu block
	 (output <= (output * (power 10 right)))                 ;;
	 (output <= (output + (remainder n (power 10 right)))))) ;; all digits to right of iii block

(define procedure "rule4" (n)
  (block 0 begin
	 (if ((count-digits n) < 2) then
	     (quit block 0))
	 (output <= 0)
	 ((cell 0) <= 0) ;; right position
	 (loop (minus (count-digits n) 1) times
	       (block 1 begin
		      (if ((get-digits n ((cell 0) + 1) (cell 0)) = 0) then
			  (block 2 begin
				 (print (drop-uu n (cell 0)))
				 (output <= (output + 1))))
		      ((cell 0) <= ((cell 0) + 1))))))

(define procedure "rule1-makes?" (n m)
  (block 0 begin
	 (if (not ((last-digit n) = 1)) then
	     (quit block 0))
	 ((cell 0) <= (n * 10))
	 (if ((cell 0) = m) then
	     (output <= yes))))

(define procedure "rule2-makes?" (n m)
  (block 0 begin
	 (if ((not ((first-digit n) = 3)) or ((count-digits n) < 2)) then
	     (quit block 0))
	 ((cell 0) <= (n * (power 10 (minus (count-digits n) 1))))
	 ((cell 0) <= ((cell 0) + (remove-first-digit n)))
	 (if ((cell 0) = m) then
	     (output <= yes))))

(define procedure "rule3-makes?" (n m)
  (block 0 begin
	 (if ((count-digits n) < 3) then
	     (quit block 0))
	 ((cell 0) <= 0) ;; right position
	 (loop at most (minus (count-digits n) 2) times
	       (block 1 begin
		      (if ((get-digits n ((cell 0) + 2) (cell 0)) = 111) then
			  (block 2 begin
				 (if ((replace-iii n (cell 0)) = m) then
				     (block 3 begin
					    (output <= yes)
					    (quit block 0)))))
		      ((cell 0) <= ((cell 0) + 1))))))

(define procedure "rule4-makes?" (n m)
  (block 0 begin
	 (if ((count-digits n) < 2) then
	     (quit block 0))
	 ((cell 0) <= 0) ;; right position
	 (loop at most (minus (count-digits n) 1) times
	       (block 1 begin
		      (if ((get-digits n ((cell 0) + 1) (cell 0)) = 0) then
			  (block 2 begin
				 (if ((drop-uu n (cell 0)) = m) then
				     (block 3 begin
					    (output <= yes)
					    (quit block 0)))))
		      ((cell 0) <= ((cell 0) + 1))))))

(define procedure "valid-step?" (n m)
  (block 0 begin
	 (if (rule1-makes? n m) then
	     (block 1 begin
		    (output <= yes)
		    (quit block 0)))
	 (if (rule2-makes? n m) then
	     (block 2 begin
		    (output <= yes)
		    (quit block 0)))
	 (if (rule3-makes? n m) then
	     (block 3 begin
		    (output <= yes)
		    (quit block 0)))
	 (if (rule4-makes? n m) then
	     (block 4 begin
		    (output <= yes)
		    (quit block 0)))))

(define procedure "first-miu-number" (d)
  (block 0 begin
	 (if (not ((first-digit d) = 3)) then
	     (quit block 0))
	 ((cell 0) <= (minus (count-digits d) 1))
	 ((cell 1) <= (cell 0))
	 (loop at most (cell 0) times
	       (block 1 begin
		      (if ((get-digit d (minus (cell 1) 1)) = 3) then
			  (abort loop 1))
		      ((cell 1) <= (minus (cell 1) 1))))
	 (output <= (get-digits d (cell 0) (cell 1)))))

(define procedure "remove-first-miu-number" (d)
  (block 0 begin
	 (if (not ((first-digit d) = 3)) then
	     (quit block 0))
	 (output <= (minus (count-digits d) (count-digits (first-miu-number d))))
	 (output <= (remainder d (power 10 output)))))

;; note: this version of miu-proof-pair? assumes that each line of a
;; derivation follows directly from the previous line. but this is too
;; stringent a requirement. each line only needs to follow from SOME
;; previous line, not necessarily the immediately preceding line. this
;; is do-able, but would require introducing an extra loop into the code.

(define procedure "miu-proof-pair?" (d n)
  (block 0 begin
	 ((cell 0) <= (first-miu-number d))
	 (if (not ((cell 0) = 31)) then
	     (quit block 0))
	 ((cell 1) <= (remove-first-miu-number d))
	 (loop at most (count-digits d) times
	       (block 1 begin
		      (if ((cell 1) = 0) then
			  (abort loop 1))
		      ((cell 2) <= (first-miu-number (cell 1)))
		      (if (not (valid-step? (cell 0) (cell 2))) then
			  (quit block 0))
		      ((cell 0) <= (cell 2))
		      ((cell 1) <= (remove-first-miu-number (cell 1)))))
	 (if ((cell 0) = n) then
	     (output <= yes))))

;; outputs the number of new strings created from n in one step
(define procedure "apply-rules" (n)
  (block 0 begin
	 (output <= (rule1 n))
	 (output <= (output + (rule2 n)))
	 (output <= (output + (rule3 n)))
	 (output <= (output + (rule4 n)))))