; tsil.scm
; Constructors: Lin, Snoc
; Constants: Append displayed as :+:, Lh, Proj displayed as __, Lead, Last

(if (not (assoc "nat" ALGEBRAS))
    (myerror "First execute (load \"~/minlog/lib/nat.scm\")"))

(display "loading tsil.scm ...") (newline)

(add-param-alg "tsil" 'prefix-typeop
	       '("Lin" "tsil")
	       '("Snoc" "tsil=>alpha1=>tsil"))


; Infix notation allowed (and type parameters omitted) for binary 
; constructors, as follows.  This would also work for prefix notation.
; Example: :: for Cons.  x::y::z: 


(add-token
 "::"
 'pair-op
 (lambda (xs x)
   (let* ((type (term-to-type x))
	  (listtype (term-to-type xs)))
     (if (and (alg-form? listtype)
	      (string=? "tsil" (alg-form-to-name listtype))
	      (equal? type (car (alg-form-to-types listtype))))
	 (mk-term-in-app-form
	  (make-term-in-const-form
	   (let* ((constr (constr-name-to-constr "Snoc"))
		  (tvars (const-to-tvars constr))
		  (subst (make-substitution tvars (list type))))
	     (const-substitute constr subst #f)))
	   xs x)
	 (myerror "parse error: types do not fit for"
		  (type-to-string listtype)
		  "::"
		  (type-to-string type))))))

(add-display
 (py "tsil alpha")
 (lambda (x)
   (let* ((op (term-in-app-form-to-final-op x))
	  (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "Snoc"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'pair-op "::"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))


(add-token
 ":"
 'prefix-op
 (lambda (x)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((constr (constr-name-to-constr "Snoc"))
	    (tvars (const-to-tvars constr))
	    (subst (make-substitution tvars (list (term-to-type x)))))
       (const-substitute constr subst #f)))
    (make-term-in-const-form
     (let* ((constr (constr-name-to-constr "Lin"))
	    (tvars (const-to-tvars constr))
	    (subst (make-substitution tvars (list (term-to-type x)))))
       (const-substitute constr subst #f)))
    x)))

(add-display
 (py "tsil alpha")
 (lambda (x)
   (let* ((op (term-in-app-form-to-final-op x))
	  (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "Snoc" (const-to-name
				(term-in-const-form-to-const op)))
	      (= 2 (length args))
	      (term-in-const-form? (cadr (reverse args)))
	      (string=? "Lin" (const-to-name
			       (term-in-const-form-to-const 
				(cadr (reverse args))))))
	 (list 'prefix-op ":" (term-to-token-tree (car (reverse args))))
	 #f))))


(add-program-constant "TsilAppend"
		      (py "tsil alpha => tsil alpha => tsil alpha")
		      1 'const 2)

(add-token
 ":+:"
 'mul-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "TsilAppend"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type x))
	    (type (car (alg-form-to-types listtype)))
	    (subst (make-substitution tvars (list type))))
       (const-substitute const subst #f)))
    x y)))

(add-display
 (py "tsil alpha")
 (lambda (x)
   (let* ((op (term-in-app-form-to-final-op x))
	  (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "TsilAppend"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'mul-op ":+:"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))


(add-computation-rule
 (pt "(tsil alpha)_1:+:(Lin alpha)")
 (pt "(tsil alpha)_1"))

(add-computation-rule
 (pt "(tsil alpha)_1 :+:((tsil alpha)_2::(alpha)_3)")
 (pt "(tsil alpha)_1:+:(tsil alpha)_2::(alpha)_3"))



(add-program-constant "TsilLength" (py "tsil alpha => nat") 1 'const 1)

(add-token
 "Lh" 'prefix-op 
 (lambda (x) (make-term-in-app-form
	      (make-term-in-const-form
	       (let* ((const (pconst-name-to-pconst "TsilLength"))
		      (tvars (const-to-tvars const))
		      (listtype (term-to-type x))
		      (type (car (alg-form-to-types listtype)))
		      (subst (make-substitution tvars (list type))))
		 (const-substitute const subst #f)))
	      x)))

(add-display
 (py "nat")
 (lambda (x)
   (if (term-in-app-form? x)
       (let ((op (term-in-app-form-to-op x)))
	 (if (and (term-in-const-form? op)
		  (string=? "TsilLength"
			    (const-to-name (term-in-const-form-to-const op))))
	     (list 'prefix-op "Lh"
		   (term-to-token-tree (term-in-app-form-to-arg x)))
	     #f))
       #f)))

(add-computation-rule (pt "Lh(Lin alpha)") (pt "0"))
(add-computation-rule (pt "Lh(tsil alpha::alpha)") (pt "++ Lh tsil alpha"))
(add-rewrite-rule
 (pt "Lh((tsil alpha)_1 :+: (tsil alpha)_2)")
 (pt "Lh(tsil alpha)_1+Lh(tsil alpha)_2"))


;projection: if t=[t_0,...,t_{n-1}] (proj t i) yields t_i
;note that proj t n should only be used for  n<=Length t 

(add-program-constant "TsilProj" (py "tsil alpha => nat => alpha") 1 'const 2)


(add-token
 "__"
 'mul-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "TsilProj"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type x))
	    (type (car (alg-form-to-types listtype)))
	    (subst (make-substitution tvars (list type))))
       (const-substitute const subst #f)))
    x y)))

(add-display
 (py "alpha")
 (lambda (x)
   (let* ((op (term-in-app-form-to-final-op x))
	  (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "TsilProj"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'mul-op "__"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))


(add-computation-rule (pt "((tsil alpha)_1::alpha)__n")
                      (pt "[if (n=Lh (tsil alpha)_1) alpha 
                           ((tsil alpha)_1__n)]"))


(add-program-constant "TsilLead" (mk-arrow (py "tsil alpha")
				       (py "tsil alpha")) 1 'const 1)
(add-program-constant "TsilLast" (mk-arrow (py "tsil alpha")
				       (py "alpha")) 1 'const 1)

(add-token
 "Lead" 'prefix-op 
 (lambda (x) (make-term-in-app-form
	      (make-term-in-const-form
	       (let* ((const (pconst-name-to-pconst "TsilLead"))
		      (tvars (const-to-tvars const))
		      (listtype (term-to-type x))
		      (type (car (alg-form-to-types listtype)))
		      (subst (make-substitution tvars (list type))))
		 (const-substitute const subst #f)))
	      x)))

(add-display
 (py "alpha")
 (lambda (x)
   (if (term-in-app-form? x)
       (let ((op (term-in-app-form-to-op x)))
	 (if (and (term-in-const-form? op)
		  (string=? "TsilLead"
			    (const-to-name (term-in-const-form-to-const op))))
	     (list 'prefix-op "Lead"
		   (term-to-token-tree (term-in-app-form-to-arg x)))
	     #f))
       #f)))

(add-token
 "Last" 'prefix-op 
 (lambda (x) (make-term-in-app-form
	      (make-term-in-const-form
	       (let* ((const (pconst-name-to-pconst "TsilLast"))
		      (tvars (const-to-tvars const))
		      (listtype (term-to-type x))
		      (type (car (alg-form-to-types listtype)))
		      (subst (make-substitution tvars (list type))))
		 (const-substitute const subst #f)))
	      x)))

(add-display
 (py "alpha")
 (lambda (x)
   (if (term-in-app-form? x)
       (let ((op (term-in-app-form-to-op x)))
	 (if (and (term-in-const-form? op)
		  (string=? "TsilLast"
			    (const-to-name (term-in-const-form-to-const op))))
	     (list 'prefix-op "Last"
		   (term-to-token-tree (term-in-app-form-to-arg x)))
	     #f))
       #f)))

(add-computation-rule (pt "Lead (Lin alpha)") (pt "(Lin alpha)")) ;!
(add-computation-rule (pt "Lead ((tsil alpha)_1::alpha_2)")
		      (pt "(tsil alpha)_1"))
; (add-computation-rule (pt "Last (Lin alpha)")
; 		      (type-to-canonical-inhabitant (py "alpha")))
(add-computation-rule (pt "Last ((tsil alpha)_1::alpha_2)")
		      (pt "alpha_2"))

(add-program-constant "TsilMap"
                      (py "(alpha1 => alpha2) => tsil alpha1 => tsil alpha2")
                      1 'const 2)
(add-computation-rule
 (pt "(TsilMap alpha1 alpha2) (alpha1=>alpha2)_1  (Lin alpha1)")
 (pt "(Lin alpha2)"))
(add-computation-rule
 (pt "(TsilMap alpha1 alpha2) (alpha1=>alpha2)_1  ((tsil alpha1)_1::alpha1)")
 (pt "((TsilMap alpha1 alpha2) (alpha1=>alpha2)_1 (tsil alpha1)_1)::
      ((alpha1=>alpha2)_1 alpha1)"))

(add-token
 "Map"
 'prefix-op
 (lambda (x)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "TsilMap"))
            (tvars (const-to-tvars const))
            (func-type (term-to-type x))
            (types (list (arrow-form-to-arg-type func-type)
                         (arrow-form-to-val-type func-type)))
            (subst (make-substitution tvars types)))
       (const-substitute const subst #f)))
    x)))

;(dt (nt  (pt "Map Pred (Lin nat)")));ok
;(dt (nt  (pt "Map Pred ((:2::3)::4)")));ok

; (add-display
;  (py "tsil alpha2")
;  (lambda (x)
;    (let* ((op (term-in-app-form-to-final-op x))
; 	  (args (term-in-app-form-to-args x)))
;      (if (and (term-in-const-form? op)
; 	      (string=? "TsilMap"
; 			(const-to-name (term-in-const-form-to-const op)))
; 	      (= 2 (length args)))
; 	 (list 'prefix-op "Map"
; 	       (term-to-token-tree (car args))
; 	       (term-to-token-tree (cadr args)))
; 	 #f))))

;(av "ll" (py "(tsil nat)"))
;(dt (nt  (pt "Map Pred ll"))) ; Map Pred> ???
