#: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")
-;;;; 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))))
projects / vouivre.git / commitdiff