test.lispy

;; -*- mode: scheme -*- 
(prog
 (define id (lambda (x) x))
 (define succ (lambda (x) (+ 1 x)))
 (define pred (lambda (x) (- 1 x)))
 (define const (lambda (x) (lambda () x)))
 (define compose (lambda (f g) (lambda (x) (f (g x)))))
 (define not (lambda (x) (if x false true)))

 (assert (= (id 1) 1))
 (assert (= (succ 1) 2))
 (assert (= ((compose succ succ) 1) 3))
 (assert (= ((const 1) 2) 1))

 ;; Arity is not being take in account, any function can
 ;; be called with any number of arguments, this is more
 ;; an implementation detail (or a bug) than something
 ;; intentional
 (assert (= ((lambda () :foo) 1 2 3 4 5) :foo))

 ;; Let macro
 (define-macro let (x e1 e2)
   ((lambda (x) e2) e1))

 (assert (= (let x 1 (+ x x)) 2))
 (assert (= (let f (lambda (y) (* y 3)) (f 4)) 12))

 ;; and macro
 (define-macro and (a b) (if a b false))
 (assert (= (and true true) true))
 (assert (= (and true false) false))
 (assert (= (and false true) false))
 (assert (= (and false false) false))

 ;; or macro
 (define-macro or (a b) (if a true b))
 (assert (= (or true true) true))
 (assert (= (or true false) true))
 (assert (= (or false true) true))
 (assert (= (or false false) false))

 ;; implies macro
 (define-macro implies (a b) (if a b true))
 (assert (= (implies true true) true))
 (assert (= (implies true false) false))
 (assert (= (implies false true) true))
 (assert (= (implies false false) true))
 ;; setup an alias

 ;; xor macro
 (define-macro xor (a b) (if a (not b) b))
 (assert (= (xor true true) false))
 (assert (= (xor true false) true))
 (assert (= (xor false true) true))
 (assert (= (xor false false) false))

 ;; We can absue the substitution mechanism and define
 ;; let like this
 (define-macro letin (x = e1 in e2)
   ((lambda (x) e2) e1))
 (assert (= (letin x = 1 in (+ x x)) 2))

 ;; infix macro
 (define-macro infix (a f b) (f a b))
 (assert (= (infix 1 + 2) 3))

 (define -> implies)
 (assert (= (infix true  -> true)  true))
 (assert (= (infix true  -> false) false))
 (assert (= (infix false -> true)  true))
 (assert (= (infix false -> false) true))

 ;; List Scott encoding
 (define list-nil (lambda () (lambda (cons nil'') (nil''))))
 (define list-cons (lambda (cons nil') (lambda (cons' nil'') (cons' cons nil'))))

 (define l (list-cons 1 (list-cons 2 (list-cons 3 (list-nil)))))

 (define list-fold
    (lambda (l f acc k)
      (let empty (lambda () acc)
      (let not-empty 
          (lambda (head tail) (k tail f (f head acc) k))
        (l not-empty empty)))))

 (assert (= (l (lambda (head tail) head) (lambda () 0)) 1))
 (assert (= (fix list-fold l + 0) 6))

 ;; Testing closure capturing
 (define x 1)
 (assert (= ((lambda () x) 100) x))
 (assert (= ((lambda () 100)) 100)) ;; IFFE
 (define f (lambda (k) (lambda () (k 1))))
 (assert (= ((f succ)) 2))

 ;; Factorial with fix
 (define fact (lambda (x k) (if (= x 0) 1 (* x (k (- x 1) k)))))
 (assert (= (fix fact 5) 120))

 ;; Factorial without fix
 (define fact' (lambda (x) (if (= x 0) 1 (* x (fact' (- x 1))))))
 (assert (= (fact' 5) 120))

 ;; Pairs
 (define pair (lambda (a b) (lambda (f) (f a b))))
 (define fst (lambda (p) (p (lambda (a b) a))))
 (define snd (lambda (p) (p (lambda (a b) b))))
 (let p (pair :a :b)
   (prog
    (assert (= (fst p) :a))
    (assert (= (snd p) :b))))

 ;; Maps
 (define map.empty (lambda (k v m) (lambda () nil)))
 (define map.add (lambda (k v m)
		   (lambda (k')
		     (if (= k k')
			 v
			 (m k')))))
 (let m (map.empty)
 (let m (map.add :foo 1 m)
 (let m (map.add :bar 2 m)
    (prog
     (assert (= (+ (m :foo) (m :bar)) 3))
     (assert (= (m :tar) nil))
    ))))
 


 ;; monads are encoded as a pair e, with bind as fst and return as
 ;; snd e stands for evidence
 ;; borrowed from https://stackoverflow.com/a/8936209/652528

 (define bind (lambda (e) (fst e)))
 (define return (lambda (e) (snd e)))

 ;; option monad
 (define opt.some (lambda (x) (lambda (f z) (f x))))
 (define opt.nothing (lambda (f z) z))
 (define opt.bind (lambda (m f) (m f opt.nothing)))
 (define opt.return opt.some)
 (define opt.monad (pair opt.bind opt.return))
 (define opt.succ (compose opt.return succ))
 (define opt.pred (lambda (x)
		   (if (> x 0)
		       (opt.return (pred x))
		       opt.nothing)))
 (define opt.some? (lambda (m) (m (const true) false)))
 (define opt.nothing? (compose not opt.some?))

 (assert (= ((opt.some 1) (const :is_some) :is_nothing) :is_some))
 (assert (= (opt.nothing (const :is_some) :is_nothing) :is_nothing))
 (assert (= ((opt.return 1) (const :is_some) :is_nothing) :is_some))
 (assert (= ((opt.some 1) succ :is_nothing) 2))
 (assert (= ((opt.bind (opt.some 1) opt.succ) id 0) 2))
 (assert (= ((opt.bind opt.nothing opt.succ) id 0) 0))
 (assert (= ((opt.bind (opt.some 1) opt.pred) id :negative) 0))
 (assert (= ((opt.bind (opt.some 0) opt.pred) id :negative) :negative))
 (assert (opt.some? (opt.some 1)))
 (assert (opt.nothing? opt.nothing))

 ;; Lets try lists WIP
 (define list.nil (lambda (c z) z))
 (define list.cons (lambda (h t c z) (c h (t c z))))
 (define list.bind (lambda (m f) (list.concat (list.map f m))))
 (define list.return (lambda (x) (list.cons x list.nil)))
 (define list.monad (pair list.bind list.return))
 (define list.concat (lambda (l) (l list.append list.nil)))
 (define list.append (lambda (x y) (x list.cons y)))

 )