From c7d1db162ca44e8be395f090b23a00557399e647 Mon Sep 17 00:00:00 2001
From: admin <admin@vouivredigital.com>
Date: Thu, 21 Sep 2023 13:07:42 +0900
Subject: [PATCH] Change argument counting to type construction

Instead of counting the arguments a function can receive
we now construct its type. Anything but functions has
a type of 0 while (curried) functions are typed with cons
cells containing the type of its domain and codomain.
---
 curry-tests.scm | 123 +++++---------
 curry.scm       | 442 ++++++++++++++++++++++++++++++++++++------------
 2 files changed, 375 insertions(+), 190 deletions(-)

diff --git a/curry-tests.scm b/curry-tests.scm
index d866c0d..b39c879 100644
--- a/curry-tests.scm
+++ b/curry-tests.scm
@@ -2,88 +2,45 @@
   #:use-module (vdc curry)
   #:use-module (srfi srfi-64))
 
-(define e (compose primitive-eval expand-cfs))
-
 (test-begin "curry")
-
-;;;; curry-proc and enhance-cf
-
-(let ((+ (enhance-cf (curry-proc + 3) 3)))
-  (test-equal 6 (+ 1 2 3))
-  (test-equal 6 (((+ 1) 2) 3))
-  (test-equal 6 ((+ 1 2) 3))
-  (test-equal 6 ((+ 1) 2 3))
-  (let ((f (enhance-cf (lambda (f) (f 1)) 3)))
-    (test-equal 6 (f + 2 3))
-    (test-equal 6 ((f + 2) 3))
-    (test-equal 6 (((f +) 2) 3))))
-
-(let* ((f (enhance-cf (curry-proc * 2) 2))
-       (g (enhance-cf (lambda (x) (f x)) 2)))
-  (test-equal 6 (g 2 3))
-  (test-equal 6 ((g 2) 3)))
-
-;; CF-free expression
-(test-equal 3 (e '(+ 1 2)))
-
-;; invalid zero variable CF
-(test-error (e '((λc () #t))))
-
-;; unclosed CF
-(test-error (e '(λc (x) x)))
-
-;; open CF as argument to a CF
-(test-equal 3 (e '((λc (f) (f 2))
-		   ((λc (a b) (+ a b))
-		    1))))
-
-;; CF applied to too many arguments
-(test-error (e '((λc (x) x) 1 2)))
-
-;; open CF as argument to something other than a CF
-(test-error (e '(+ 1 (λc (x) x))))
-
-;; composition
-;; ∘ ≡ function composition ≡ (λc (g f) (λc (x) (g (f x))))
-;; ۰ ≡ flipped ∘ ≡ (λc (f g) (λc (x) (g (f x))))
-(test-equal (expt (1+ 1) 3)
-  ;; (∘ expt 1+ 1 3)
-  (e '((λc (g f) (λc (x) (g (f x))))	; ∘
-       (λc (x y) (expt x y))		; expt
-       1+ 1 3)))
-(test-equal (expt (1+ 1) 3)
-  ;; ((∘ expt 1+) 1 3)
-  (e '(((λc (g f) (λc (x) (g (f x))))	; ∘
-	(λc (x y) (expt x y))		; expt
-	1+)
-       1 3)))
-(test-equal (expt (1+ 1) 3)
-  ;; (((∘ expt 1+) 1) 3)
-  (e '((((λc (g f) (λc (x) (g (f x))))	; ∘
-	 (λc (x y) (expt x y))		; expt
-	 1+)
-	1)
-       3)))
-(test-equal (1+ (expt 2 3))
-  ;; ((∘ (∘ 1+) expt) 2 3)
-  (e '(((λc (g f) (λc (x) (g (f x))))	; ∘
-	((λc (g f) (λc (x) (g (f x))))	; ∘
-	 (λc (x) (1+ x)))		; 1+
-	(λc (x y) (expt x y))		; expt
-	)
-       2 3)))
-(test-equal (expt 2 (1+ 3))
-  ;; (expt x (1+ y)) ≡ (∘ (۰ 1+) expt)
-  (e '(((λc (g f) (λc (x) (g (f x))))			; ∘
-	((λc (f g) (λc (x) (g (f x)))) (λc (x) (1+ x))) ; (۰ 1+)
-	(λc (x y) (expt x y))				; expt
-	)
-       2 3)))
-
-;; misc
-(test-equal 3 (e '(+ 1 ((λc (x) x) 2))))
-(test-equal 6 (e '((((λc (x y z)
-                         (+ x y z))
-		     1) 2) 3)))
-
+;; TODO: map the reduxtab to a bare version for unit-testing
+;; (test-assert
+;;     (lset=
+;;      'equal?
+;;      '((1 . (2 . 4)) (2 . 2) (3 . 2))
+;;      (compare
+;;       (parse '(1       . (2 . 3)))
+;;       (parse '((1 . 2) . (1 . 1))))))
+(test-equal '(1 . 1)
+  (t '() '(lambda x x)))
+(test-equal '((3 . 4) . ((2 . 3) . (2 . 4)))
+  (t '() '(lambda g (lambda f (lambda x (g (f x)))))))
+(test-equal 0
+  (t '() '((lambda x x) #t)))
+(let ((bindings `((id  . ,(parse '(1 . 1)))
+		  (∘   . ,(parse '((2 . 3) . ((1 . 2) . (1 . 3)))))
+		  (⊙   . ,(parse '((1 . 2) . ((2 . 3) . (1 . 3)))))
+		  (map . ,(parse '((0 . 0) . (0 . 0))))
+		  (+   . ,(parse '(0 . (0 . 0)))))))
+  (test-equal '(7 . 7)
+    (t bindings '(∘ id id)))
+  (test-equal 0
+    (t bindings '((∘ id id) #t)))
+  (test-equal 0
+    (t bindings '(∘ id id #t)))
+  (test-equal 0
+    (t bindings '(map (+ 1) '(1 2 3))))
+  (test-equal '((9 . 0) . (9 . (0 . 0)))
+    (t bindings '(∘ +)))
+  (test-equal 0
+    (t bindings '((∘ +) (+ 1) 2 3)))
+  (test-equal 0
+    (t bindings '((∘ + (+ 1)) 2 3)))
+  (test-equal 0
+    (t bindings '(((∘ + (+ 1)) 2) 3)))
+  (test-equal 0
+    (t bindings '((∘ (∘ (+ 1)) +) 2 3)))
+  (test-equal 0
+    (t bindings '((∘ (⊙ (+ 1)) +) 2 3)))
+  )
 (test-end "curry")
diff --git a/curry.scm b/curry.scm
index c1b5fc2..edb4550 100644
--- a/curry.scm
+++ b/curry.scm
@@ -1,110 +1,338 @@
-;;;; The following code adds syntax for creating and partially applying curried
-;;;; functions (CFs) in Scheme. The code also raise errors, at syntax expansion
-;;;; time, if CFs aren't applied properly. A simple valid use case is as follow:
-;;;;     (((λc (x y z) (+ x y z)) 1 2) 3)
-;;;; while the following raises an error:
-;;;;     ((λc (x) x) 1 2)
-;;;; See "partial-tests.scm" for more examples and continue reading for
-;;;; implementation details.
-;;;;
-;;;; When a CF is created, a remaining maximum applicable number of arguments
-;;;; (RMANA) is associated to it. The RMANA decreases as the CF gets applied
-;;;; and, when it reaches zero, it can no longer be applied. The system also
-;;;; associates `#f' RMANA to Scheme expressions that can't be partially
-;;;; applied. We say that an expression is closed when its RMANA is false or zero
-;;;; and opened otherwise. The distinction between expressions with false vs
-;;;; zero RMANA is that the former is applicable to any number of closed
-;;;; argument while the latter can't be applied at  all. The system verifies
-;;;; that CFs aren't (both immediately and ultimately) applied to too many
-;;;; arguments and that all CFs are ultimately closed.
-
 (define-module (vdc curry)
-  #:use-module (vdc misc)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-71)
+  #:use-module ((ice-9 curried-definitions) :prefix c)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-64)
+  #:use-module (vdc misc)
+  #:replace
+  ((vdc:define . define)
+   (vdc:primitive-eval . primitive-eval))
   #:export
-  (curry-proc
-   enhance-cf
-   expand-cfs))
-
-(define (bind-var bindings var val)
-  (assoc-set! bindings var val))
-
-(define (bind-vars bindings vars vals)
-  (fold (lambda (x y prev) (bind-var prev x y)) bindings vars vals))
-
-(define (closed? x)
-  (or (not x)
-      (zero? x)))
-
-(define opened? (compose not closed?))
-
-(define (curry-proc proc n)
-  (let curry ((n n)
-	      (stack '()))
-    (if (= 0 n)
-	(apply proc (reverse stack))
-	(lambda (x)
-	  (curry (1- n)
-		 (cons x stack))))))
-
-(define (enhance-cf f n)
-  (lambda (x . xs)
-    (let ((r (- n 1 (length xs))))
-      ((if (= 0 r)
-	   identity
-	   (lambda (x) (enhance-cf x r)))
-       (fold (lambda (x prev)
-	       (prev x))
-	     (f x) xs)))))
-
-(define* (preturn expr_ m #:optional ns)
-  "Return an expanded expression and it's RMANA or throw an error if we are
-trying to apply it to too many. `expr_' is an expanded expression, `m' its
-RMANA, and `ns' the RMANAs of the applied arguments, if any."
-  (values
-   expr_
-   (cond
-    ((and (not m) ns (any opened? ns))
-     (error "non-CFs can't be applied to opened CFs."))
-    ((and m ns (< m (length ns)))
-     (error "too many arguments." expr_ m ns))
-    ((and m ns)
-     (- m (length ns)))
-    (else m))))
-
-(define (expand-cfs x)
-  (define (it x args bindings)
-    (match
-	x
-      (('λc (vars ..1) body)
-       (let* ((body_ n (it body '() (bind-vars bindings vars args)))
-	      (m (length vars))
-	      (rmana (or (and n (+ n m))
-			 m)))
-	 (preturn
-          `(enhance-cf (curry-proc (lambda ,vars ,body_)
-				   ,m)
-		       ,rmana)
-	  rmana)))
-      ((f as ...)
-       (let* ((as (map
-                   (lambda (a)
-                     (receive vals (it a '() bindings) vals))
-                   as))
-              (as_ asn (unzip2 as))
-              (f_ fn (if-let
-                      (x (assoc-ref bindings f))
-                      (values f (second x))
-                      (it f as bindings))))
-         (preturn (cons f_ as_)
-                  fn asn)))
-      ((? (compose not list?) x)
-       (preturn x #f))
-      (else (error "no matching pattern in partial expanssion."))))
-  (let ((expr_ rmana (it x '() '())))
-    (if (closed? rmana)
-	expr_
-	(error "opened CF in expression."))))
+  (curry
+   parse
+   symtab
+   t
+   ∷))
+
+(define symtab '())
+
+(define-record-type node
+  (make-node content)
+  node?
+  (content node-content set-node-content!))
+
+(define (type-error n . args)
+  (let ((errors '((0 . TBD)
+		  (1 . INCOMPATIBLE)
+		  (2 . BAD-INPUT)
+		  (3 . BAD-APPLICATION)
+		  (4 . UNBOUND-SYMBOL))))
+    (apply error "type error" (assoc-ref errors n) args)))
+
+(define (zo? x)
+  (and (number? x) (zero? x)))
+
+(define (tv? x)
+  (and (number? x) (positive? x) #t))
+
+(define next
+  (let ((count 1))
+    (lambda ()
+      (set! count (1+ count))
+      (1- count))))
+
+(define (copy-tree node)
+  (let ((x (node-content node)))
+    (if (pair? x)
+	(make-node (cons (copy-tree (car x))
+			 (copy-tree (cdr x))))
+	(make-node x))))
+
+(define (map-tree! proc nx)
+  (let ((x (node-content nx)))
+    (if (pair? x)
+	(begin
+	  (map-tree! proc (car x))
+	  (map-tree! proc (cdr x)))
+	(set-node-content! nx (proc x)))
+    nx))
+
+(define (compare nx ny)
+  (define (create-reduxtab m)
+    ;; Each `x' point (through `mx') to a list `ys' of elements `y' who
+    ;; themselves point (through `my') to lists of things equal to `x'.
+    ;; We unionize these, sort them, and, bind them as "things equal to `x'".
+    (let* ((mx (first m))
+	   (my (second m))
+	   (mxf (third m))
+	   (φ (lambda (x)
+		(assoc-ref mx x)))
+	   (φ* (lambda (y)
+		 (assoc-ref my y)))
+	   (Φ* (lambda (ys)
+		 (apply lset-union eq? (map φ* ys)))))
+      (append
+       (lset-difference
+	(lambda (x y) (eq? (car x) (car y)))
+	mxf mx)
+       (map
+	(match-lambda
+	  ((x . ys)
+	   (cons
+	    x
+	    (let ((new-x (first (sort-list (Φ* ys) <)))
+		  (fy (assoc-ref mxf x)))
+	      (if (and (zo? new-x) fy)
+		  (type-error 1 new-x fy)
+		  (if (not fy)
+		      new-x
+		      (node-content
+		       (map-tree!
+			(lambda (y)
+			  (first
+			   (sort-list
+			    (or (φ* y)
+				(list (next)))
+			    <)))
+			(copy-tree (make-node fy))))))))))
+	mx))))
+  (define (massoc m x y)
+    (define (assoc! m x y)
+      (assoc-set! m x (cons y (or (assoc-ref m x) '()))))
+    (list (if (and (not (pair? x))
+		   (not (pair? y)))
+	      (assoc! (first m) x y)
+	      (first m))
+	  (if (and (not (pair? x))
+		   (not (pair? y)))
+	      (assoc! (second m) y x)
+	      (second m))
+	  (if (not (pair? y))
+	      (third m)
+	      (if (assoc-ref (third m) x)
+		  (type-error 0 "type variable already a function")
+		  (assoc-set! (third m) x y)))))
+  (create-reduxtab
+   (let compare% ((m `(()
+		       ;; 0_x ≡ 0_y (though we only use 0y→0x).
+		       ;; Also, associations in an alist need to be mutable.
+		       (,(cons 0 '(0)))
+		       ()))
+		  (nx nx)
+		  (ny ny))
+     (let ((x (node-content nx))
+	   (y (node-content ny)))
+       (cond
+	;; same same
+	((eq? nx ny)
+	 m)
+	((and (not x) (not y))
+	 m)
+	((and (zo? x) (zo? y))
+	 m)
+	((and (tv? x) (tv? y))
+	 (massoc m x y))
+	((and (pair? x) (pair? y))
+	 (compare% (compare% m (car x) (car y))
+		   (cdr x) (cdr y)))
+	;; cases with #f
+	((and (zo? x) (not y))
+	 (set-node-content! ny x)
+	 m)
+	((and (zo? y) (not x))
+	 (set-node-content! nx y)
+	 m)
+	((and (tv? y) (not x))
+	 (let ((z (next)))
+	   (set-node-content! nx z)
+	   (massoc m y z)))
+	((and (tv? x) (not y))
+	 (let ((z (next)))
+	   (set-node-content! ny z)
+	   (massoc m x z)))
+	((and (pair? x) (not y))
+	 (type-error 0 nx ny))
+	((and (pair? y) (not x))
+	 (type-error 0 nx ny))
+	;; cases with TVs
+	((and (tv? x) (zo? y))
+	 (massoc m x y))
+	((and (tv? y) (zo? x))
+	 (massoc m x y))
+	((and (tv? x) (pair? y))
+	 (massoc m x y))
+	((and (tv? y) (pair? x))
+	 (type-error 0 nx ny))
+	;; outright incompatible cases
+	((or (and (zo? x) (pair? y))
+	     (and (zo? y) (pair? x)))
+	 (type-error 1 x y))
+	;; bad input
+	(else
+	 (type-error 2 nx ny)))))))
+
+(define (reduce-tvs! reduxtab node)
+  (map-tree!
+   (lambda (x)
+     (if (number? x)
+	 (or (assoc-ref reduxtab x)
+	     x)
+	 x))
+   node))
+
+(define (rename-tvs! node)
+  (let ((mapping (cons '() #f)))
+    (map-tree!
+     (lambda (x)
+       (if (tv? x)
+	   (if-let (z (assoc-ref (car mapping) x))
+		   z
+		   (let ((z (next)))
+		     (set-car! mapping (assoc-set! (car mapping) x z))
+		     z))
+	   x))
+     node)))
+
+(define (apply-1 nx ny)
+  (let ((x (node-content nx))
+	(y (node-content ny)))
+    (cond
+     ((not x)
+      (set-node-content! nx (cons ny (make-node #f)))
+      (cdr (node-content nx)))
+     ((zo? x)
+      (type-error 3 x y))
+     ((tv? x)
+      (type-error 2 nx ny)
+      )
+     ((pair? x)
+      (reduce-tvs! (compare (car x) ny)
+		   (copy-tree (cdr x))))
+     (else
+      (type-error 2 nx ny)))))
+
+(define (var-list? lst)
+  (and (every symbol? lst)
+       (equal? lst (delete-duplicates lst))))
+
+(define (sym-set! bindings name value)
+  (let ((symtab bindings))
+    (assoc-set! symtab name value)))
+
+(define (sym-ref bindings name)
+  (assoc-ref bindings name))
+
+(define (populate-tvs! node)
+  (map-tree!
+   (lambda (x)
+     (if (not x)
+	 (next)
+	 x))
+   node))
+
+(define (sym-set symtab sym value)
+  (sym-set! (alist-copy symtab) sym value))
+
+(define (t% symtab expr)
+  (match expr
+    (('quote x)
+     (make-node 0))
+    (('lambda (? symbol? var) body)
+     (let ((var-node (make-node #f)))
+       (let ((nbody (t% (sym-set symtab var var-node)
+			body)))
+	 (populate-tvs! var-node)
+	 (make-node
+	  (cons var-node nbody)))))
+    (('letrecc1 ((? symbol? name) expr) body)
+     (type-error 0 'letrecc1 name expr body))
+    ((f)
+     (type-error 3 expr))
+    ((f as ..1)
+     (fold
+      (lambda (a prev)
+	(apply-1 prev (t% symtab a)))
+      (t% symtab f)
+      as))
+    (x
+     (if (symbol? x)
+	 (or (sym-ref symtab x)
+	     (type-error 4 x))
+	 (make-node 0)))))
+
+(define (bare-t node)
+  (let ((x (node-content node)))
+    (cond
+     ((pair? x)
+      (cons (bare-t (car x)) (bare-t (cdr x))))
+     (else x))))
+
+(define (pt node)
+  (format
+   #t "~a~%"
+   (let pt% ((nx node))
+     (let ((x (node-content nx)))
+       (cond
+	((not x)
+	 "?")
+	((number? x)
+	 (number->string x))
+	((pair? x)
+	 (format #f "(~a . ~a)"
+		 (pt% (car x))
+		 (pt% (cdr x))))))))
+  (values))
+
+(define (parse x)
+  (second
+   (let parse% ((tvs '())
+		(x x))
+     (cond
+      ((eq? x '?)
+       (list tvs (make-node #f)))
+      ((zo? x)
+       (list tvs (make-node 0)))
+      ((tv? x)
+       (if-let (z (assoc-ref tvs x))
+	       (list tvs (make-node z))
+	       (let ((tv (next)))
+		 (list (assoc-set! tvs x tv)
+		       (make-node tv)))))
+      ((pair? x)
+       (let* ((a (parse% tvs (car x)))
+	      (b (parse% (first a) (cdr x))))
+	 (list (first b) (make-node (cons (second a) (second b))))))))))
+
+(define (t symtab expr) (bare-t (t% symtab expr)))
+
+(define (curry x)
+  (match x
+    (('quote x) (quote x))
+    (('lambda (? symbol? var) body)
+     `(lambda (,var) ,(curry body)))
+    ;; (('letrecc1 ((? symbol? name) expr) body)
+    ;;  `(letrecc1 (,name ,(curry expr)) ,(curry body)))
+    ((f as ...)
+     (fold (lambda (x prev) (list prev (curry x)))
+	   (curry f)
+	   as))
+    (x x)))
+
+(define (vdc:primitive-eval expr)
+  (t% symtab expr)
+  (primitive-eval (curry expr)))
+
+(define (e symtab expr)
+  (t% symtab expr)
+  (primitive-eval (curry expr)))
+
+(define-syntax vdc:define
+  (syntax-rules ()
+    ((_ (name var) body ...)
+     (cdefine (name var) body ...))
+    ((_ (name var1 var2 ...) body ...)
+     (vdc:define ((name var1) var2 ...) body ...))))
+
+(define-syntax-rule (∷ name type)
+  (set! symtab (assoc-set! symtab 'name (parse 'type))))
-- 
2.39.5