;;
;; Solution for hw11. Efficient Recursive Subtyping
;;
;; Suggested by Markus Kuhn <kuhn>
;;


;; The extra credit problem has been solved, too.

(load "/homes/hylee/pub/source/sllgen.scm")

(define run
  (lambda (string)
    (decide-subtype-problem (scan&parse string))))

;;; ***********************************************************
;;; Lexical Specification

(define automaton
  '((bot top mu)   ; keywords
    (start-state
      ((#\space #\tab #\newline) #f)
      ((alphabetic)
       (arbno (numeric alphabetic))
       identifier)
      (#\- arrow-state)
      (#\< less-than-state)
      (#\( lparen)
      (#\) rparen)
      (#\. dot)
      (#\^ end-marker))
    (less-than-state
      (#\= subtype-of))
    (arrow-state
      (#\> arrow))))

;;; ****************************************************************
;;; Grammar

(define grammar
  '((subtyping-problem
      (type subtype-of type)
      subtyping-problem)
    (type
      (identifier)
      var-type)
    (type
      (bot)
      bottom-type)
    (type 
      (top)
      top-type)
    (type
      (lparen type arrow type rparen)
      function-type)
    (type
      (mu identifier dot type)
      recursive-type)))

(define scan&parse
  (sllgen:string->tree automaton grammar))

;;; ****************************************************************
;;; The decision procedure

;; The automaton is represented as a list of states. Every state is
;; a list with 1 or 3 elements. The first element is the label of the state,
;; which is either top, bot, or fun. The other two elements are only
;; present when the label is fun (=function) and they contain the integer
;; state number of the two successor states. States are numbered
;; according to their list position, starting with 0.

;; Build-automaton transforms a syntax tree into an automaton. The
;; subroutine check-var probes for black holes and finds recursive
;; backpointers to already existing states of the automaton. The
;; subroutine tomaton recurses over the syntax tree and constructs the
;; state list on the fly while doing so.  The programming style of
;; this routine is somewhat imperative, because across the recursive
;; calls, we not only have to return the new states, but also adjust
;; pointers of the state transition function for already created
;; states and increment the state number counter. All this is
;; difficult to handle in one single return value, therefore we do it
;; using lots of assignments.

(define build-automaton
  (lambda (type)
    (letrec
	((state-cnt 0)
	 (check-var
	  (lambda (type oldenv newenv)
	    (record-case type
	      (bottom-type () '())
	      (top-type () '())
	      (function-type (left right) '())
	      (var-type (id)
		(let ((old (assq id oldenv)))
		  (if (pair? old)
		      (cadr old)
		      (if (memq id newenv)
			  (error "black hole .... uuuuaaahhhh ...... splash")
			  (error "undefined type variable" id)))))
	      (recursive-type (id subtree)
	       (check-var subtree oldenv (cons id newenv))))))
	 (tomaton
	  (lambda (type env fix)
	    (record-case type
	      (bottom-type () 
		(set-car! fix state-cnt)
		(set! state-cnt (+ 1 state-cnt))
		'((bot)))
	      (top-type ()
                (set-car! fix state-cnt)
		(set! state-cnt (+ 1 state-cnt))
		'((top)))
	      (var-type (id) (error "unexpected type variable" id))
	      (recursive-type (id subtree)
	        (tomaton subtree (cons (list id state-cnt) env) fix))
	      (function-type (left right)
	        (let ((newstate (list 'fun '* '*))
		      (leftstates '())
		      (rightstates '())
		      (leftvar (check-var left env '()))
		      (rightvar (check-var right env '())))
		  (set-car! fix state-cnt)
		  (set! state-cnt (+ 1 state-cnt))
		  (cons
		   newstate
		   (append
		    (if (number? leftvar)
			(begin (set-car! (cdr newstate) leftvar) '())
			(tomaton left env (cdr newstate)))
		    (if (number? rightvar)
			(begin (set-car! (cddr newstate) rightvar) '())
			(tomaton right env (cddr newstate)))))))))))
      (let ((dummy (list '())))
	(check-var type '() '())
	(tomaton type '() dummy)))))

;; Compare two automatons representing two types. Returns #t if
;; automaton1 represents a subtype of the type represented by
;; automaton2. Unlike outlined in the course, this implementation does
;; not explicitely build a product automaton. The product automaton
;; appears implicitely in the rules according to which the depth first
;; search is conducted, there is no data structure representing the
;; full set of states for the product automaton. Therefore, this
;; implementation needs only O(n) memory as opposed to O(n^2) memory
;; as required by the algorithm described in the course (n being the
;; input string length).

(define is-subtype-automaton?
  (lambda (automaton1 automaton2)
    (letrec 
	((search-devil
	  (lambda (state1 state2 toggle visited)
	    (let ((marking (list state1 state2 toggle)))
	      (if (member marking visited)
		  #t
		  (let* ((rec1 (list-ref automaton1 state1))
			 (rec2 (list-ref automaton2 state2))
			 (label1 (car rec1))
			 (label2 (car rec2)))
		    (cond
		     ((and (eq? label1 'fun) (eq? label2 'fun))
		      (and
		       (search-devil (cadr  rec1) (cadr  rec2) (not toggle)
				     (cons marking visited))
		       (search-devil (caddr rec1) (caddr rec2) toggle
				     (cons marking visited))))
		     ((eq? label1 label2) #t)
		     ((and (eq? label1 'bot) (eq? label2 'top)) (not toggle))
		     ((and (eq? label1 'bot) (eq? label2 'fun)) (not toggle))
		     ((and (eq? label1 'top) (eq? label2 'bot)) toggle)
		     ((and (eq? label1 'top) (eq? label2 'fun)) toggle)
		     ((and (eq? label1 'fun) (eq? label2 'bot)) toggle)
		     ((and (eq? label1 'fun) (eq? label2 'top)) (not toggle))
		     (else (error "Oops, uncovered case!")))))))))
    (search-devil 0 0 #f '()))))

;; first build two automatons for the two types, then compare them in a
;; depth first search.
		   
(define decide-subtype-problem
  (lambda (subtype-problem)
    (record-case subtype-problem
      (subtyping-problem (sub super)
	(is-subtype-automaton? (build-automaton sub)
			       (build-automaton super))))))