; $Id: tensor.scm,v 1.4 2008/01/25 13:30:21 logik Exp $
; This is an attempt to build integers and rationals by means of a
; parametrized free algebra tensor.

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

(add-param-alg "tensor" 'tensor-typeop
	       '("Tensor" "alpha1=>alpha2=>tensor"))

; (type-to-string (py "alpha1 tensor alpha2"))
; (type-to-string (py "alpha1 tensor alpha2 tensor alpha3"))
; (type-to-string (py "alpha1 tensor (alpha2 tensor alpha3)"))

; Infix notation allowed (and type parameters omitted) for the binary 
; constructor.  n#m#k

(add-token
 "#"
 'pair-op
 (lambda (x y)
   (let* ((type1 (term-to-type x))
	  (type2 (term-to-type y)))
     (mk-term-in-app-form
      (make-term-in-const-form
       (let* ((constr (constr-name-to-constr "Tensor"))
	      (tvars (const-to-tvars constr))
	      (subst (make-substitution tvars (list type1 type2))))
	 (const-substitute constr subst #f)))
      x y))))

(add-display
 (py "alpha1 tensor 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=? "Tensor"
			(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))))

; (term-to-string (pt "boole#boole#boole"))
; (term-to-string (pt "(boole#boole)#boole"))

; (formula-to-string (pf "boole#boole=boole#boole"))
; (formula-to-string (nf (pf "(boole#boole)=(boole#boole)")))

(add-program-constant
 "tensorFst" (py "alpha1 tensor alpha2=>alpha1") 1 'const 1)

(add-token
 "fst" 'prefix-op 
 (lambda (x) (make-term-in-app-form
	      (make-term-in-const-form
	       (let* ((const (pconst-name-to-pconst "tensorFst"))
		      (tvars (const-to-tvars const))
		      (tensortype (term-to-type x))
		      (types (alg-form-to-types tensortype))
		      (type1 (car types))
		      (type2 (cadr types))
		      (subst (make-substitution tvars (list type1 type2))))
		 (const-substitute const subst #f)))
	      x)))

(add-display
 (py "alpha1")
 (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=? "tensorFst"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 1 (length args)))
	 (list 'prefix-op "fst"
	       (term-to-token-tree (car args)))
	 #f))))

; (term-to-string (nt (pt "fst(boole1#boole2)")))

(add-computation-rule
 (pt "(tensorFst alpha1 alpha2)((Tensor alpha1 alpha2)alpha1 alpha2)")
 (pt "alpha1"))

; ok, computation rule fst(alpha1#alpha2) -> alpha1 added

; (term-to-string (nt (pt "fst(boole1#boole2)")))

(add-program-constant
 "tensorSnd" (py "alpha1 tensor alpha2=>alpha2") 1 'const 1)

(add-token
 "snd" 'prefix-op 
 (lambda (x) (make-term-in-app-form
	      (make-term-in-const-form
	       (let* ((const (pconst-name-to-pconst "tensorSnd"))
		      (tvars (const-to-tvars const))
		      (tensortype (term-to-type x))
		      (types (alg-form-to-types tensortype))
		      (type1 (car types))
		      (type2 (cadr types))
		      (subst (make-substitution tvars (list type1 type2))))
		 (const-substitute const subst #f)))
	      x)))

(add-display
 (py "alpha1")
 (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=? "tensorSnd"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 1 (length args)))
	 (list 'prefix-op "snd"
	       (term-to-token-tree (car args)))
	 #f))))

; (term-to-string (nt (pt "snd(boole1#boole2)")))

(add-computation-rule
 (pt "(tensorSnd alpha1 alpha2)((Tensor alpha1 alpha2)alpha1 alpha2)")
 (pt "alpha2"))

; ok, computation rule snd(alpha1#alpha2) -> alpha1 added

; (term-to-string (nt (pt "snd(boole1#boole2)")))

; (add-pvar-name "Q" (make-arity (py "boole tensor boole")))
; (add-var-name "p" (py "boole tensor boole"))
; (set-goal (pf "all boole1,boole2 Q (boole1#boole2) ->
;                all p Q p"))
; (assume 1)
; (ind)
; (use 1)

; Added 04-05-04

(define (term-in-tensor-form? term)
  (and (term-in-app-form? term)
       (let ((op (term-in-app-form-to-final-op term))
	     (args (term-in-app-form-to-args term)))
	 (and (term-in-const-form? op)
	      (string=? "Tensor"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args))))))

; (term-in-tensor-form? (pt "1#k"))

(define (term-in-tensor-form-to-fst term)
  (let ((args (term-in-app-form-to-args term)))
    (if (= 2 (length args))
	(car args)
	(myerror "term-in-tensor-form-to-fst" "two argumments expected"
		 (term-to-string term)))))

; (term-to-string (term-in-tensor-form-to-fst (pt "1#k")))

(define (term-in-tensor-form-to-snd term)
  (let ((args (term-in-app-form-to-args term)))
    (if (= 2 (length args))
	(cadr args)
	(myerror "term-in-tensor-form-to-snd" "two argumments expected"
		 (term-to-string term)))))

; (term-to-string (term-in-tensor-form-to-snd (pt "1#k")))  

