Apêndice B: Mais Exemplos de Majestic Lisp

;; -*- mode: lisp; mode: majestic; -*-

;; defmac macro
(def defmac
  (mac (label lambda-list . body)
       `(def ,label
            (mac ,lambda-list ,@body))))

;; defn macro
(defmac defn (label lambda-list . body)
  `(def ,label (fn ,lambda-list ,@body)))

;; when macro
(defmac when (pred . body)
  `(if ,pred (do ,@body) nil))

;; unless macro
(defmac unless (pred . body)
  `(if (not ,pred) (do ,@body) nil))

;; until macro
(defmac until (pred . body)
  `(while (not ,pred) ,@body))

;; cond macro
(defmac cond clauses
  (if (nilp clauses)
      nil
      `(if ,(caar clauses)
           (do ,@(cdar clauses))
           ,(if (nilp (cdr clauses))
                nil
                (cons 'cond (cdr clauses))))))

;; let macro
(defmac let (args . body)
  ((fn (sepfn)
     ((fn ((syms vals))
        `((fn ,syms ,@body)
          ,@vals))
      (sepfn args nil nil sepfn)))
   (fn (pairs syms vals recur)
       (if (nilp pairs)
           (list syms vals)
           (recur (cdr pairs)
                  (cons (caar pairs) syms)
                  (cons (car (cdar pairs)) vals)
                  recur)))))

;; let* macro
(defmac let* (clauses . body)
  (if (nilp clauses)
      (cons 'do body)
      `(let (,(car clauses))
         ,(if (nilp (cdr clauses))
              (cons 'do body)
              `(let* ,(cdr clauses)
                 ,@body)))))

;; letfn macro
(defmac letfn (defs . body)
  ((fn (sepfn)
     ((fn ((syms vals))
        `((fn ,syms ,@body)
          ,@vals))
      (sepfn defs nil nil sepfn)))
   (fn (pairs syms vals recur)
       (if (nilp pairs)
           (list syms vals)
           (recur (cdr pairs)
                  (cons (caar pairs) syms)
                  (cons (cons 'fn (cdar pairs)) vals)
                  recur)))))

;; letfn* macro
(defmac letfn* (clauses . body)
  (if (nilp clauses)
      (cons 'do body)
      `(letfn (,(car clauses))
         ,(if (nilp (cdr clauses))
              (cons 'do body)
              `(letfn* ,(cdr clauses)
                 ,@body)))))

;; map function
(defn map (f (x . xs))
  (unless (nilp x)
    (cons (f x)
          (map f xs))))

;; mapc function
(defn mapc (f (x . xs))
  (unless (nilp x)
    (f x)
    (mapc f xs)))

;; assp function
(defn assp (proc (x . xs))
  (unless (nilp x)
    (let (((key . rest) x))
      (or (and (proc key) x)
          (assp proc xs)))))

;; assoc function
(defn assoc (sym alist)
  (assp (equal sym) alist))

;; functionp function
(defn functionp (f)
  (or (primitivep f)
      (closurep f)))

;; with-open-stream macro
(defmac with-open-stream ((sym dir file) . body)
  `(let ((,sym (open-stream ,dir ,file)))
     (unwind-protect (do ,@body)
       (close-stream ,sym))))

;; repeat macro
(defmac repeat (n . body)
  (let ((it (gensym))
        (res (gensym)))
    `(let ((,it   ,n)
           (,res nil))
       (while (> ,it 0)
         (set ,res (do ,@body))
         (set ,it (1- ,it)))
       ,res)))

;; member function
(defn member (elt lst)
  (unless (nilp lst)
    (let (((x . rest) lst))
      (or (and (equal elt x)
               lst)
          (member elt rest)))))

;; vector= function
(defn vector= (va vb)
  (when (eq (vec-type va) (vec-type vb))
    (let* ((len (vec-length va))
           (i 0)
           (continue t))
      (when (= len (vec-length vb))
        (while (and (< i len) continue)
          (unless (equal (vec-at i va)
                         (vec-at i vb))
            (set continue nil))
          (set i (1+ i)))
        continue))))

;; equal function
(defn equal (x y)
  (cond ((and (numberp x) (numberp y))
         (= x y))
        ((and (vectorp x) (vectorp y))
         (vector= x y))
        ((and (symbolp x) (symbolp y))
         (eq x y))
        ((and (consp x) (consp y))
         (when (equal (car x) (car y))
           (equal (cdr x) (cdr y))))
        ((and (atomp x) (atomp y))
         (id x y))
        (t nil)))

;; functionp function
(defn functionp (f)
  (or (primitivep f)
      (closurep f)))

;; length function (optional)
(defn length (l)
  (letrec ((iter (acc (x . xs))
             (cond ((consp xs)
                    (iter (1+ acc) xs))
                   (t acc))))
    (or (and (atomp l) 0)
        (iter 0 l))))

;; TODO: max/min functions

;; depth function (optional)
(defn depth (l)
  (letrec ((iter (l)
             (cond ((not (consp l)) 0)
                   (t (1+ (max (depth (car l))
                               (depth (cdr l))))))))
    (cond ((nilp l) 0)
          ((atomp l)
           (err "{} is an atom" l))
          (t (iter l)))))

;; TODO: append function

;; TODO: last function

;; identity function
(defn identity (x) x)

;; constantly function
(defn constantly (value)
  (fn () value))

;; TODO: mod function

;; evenp function (independent of mod)
;; this is not optimal. mod missing...
(defn evenp (x)
  (= (* (number-coerce 'integer (/ x 2)) 2)
     (number-coerce 'float x)))

;; assert macro
(defmac assert (expr value)
  (let ((value-sym (gensym)))
    `(let ((,value-sym ,value))
       (if (equal ,expr ,value-sym)
           (print ";; Passed: {} => {}" (quote ,expr) ,value-sym)
           (err "Assertion failed: equal {} {}" (quote ,expr) ,value-sym)))))

;; =======================
;; Memoization
;; =======================

(defn memo-proc (proc)
  (let ((*already-run* nil)
        (*result*      nil))
    (fn ()
      (if (not *already-run*)
          (do (set *result* (proc))
              (set *already-run* t)
              *result*)
          *result*))))

;; =======================
;; Macros for creating streams
;; =======================

(defmac delay body
  `(memo-proc (fn () ,@body)))

(defmac force (procedure)
  `(,procedure))

(defmac lazy-cons (a b)
  `(cons ,a (delay ,b)))

;; =======================
;; Stream accessors
;; =======================

(defn lazy-car (stream)
  (car stream))

(defn lazy-cdr (stream)
  (force (cdr stream)))

;; =======================
;; Stream operations
;; =======================

(def *empty-lazy* nil)

(def lazy-nil-p nilp)

(defn lazy-filter (pred stream)
  (cond ((lazy-nil-p stream)
         *empty-lazy*)
        ((pred (lazy-car stream))
         (lazy-cons (lazy-car stream)
                    (lazy-filter
                     pred
                     (lazy-cdr stream))))
        (t (lazy-filter pred (lazy-cdr stream)))))

;; Warning: This may cause a stack overflow
(defn lazy-take (stream n)
  (when (> n 0)
    (cons (lazy-car stream)
          (lazy-take
           (lazy-cdr stream)
           (1- n)))))

;; (defn map-stream (stream f)
;;   (cons-stream (f (stream-car stream))
;;                (map-stream
;;                 (stream-cdr stream)
;;                 f)))

(defn lazy-print (stream n)
  (when (> n 0)
    (print "{}" (lazy-car stream))
    (set n (1- n))
    (set stream (lazy-cdr stream))
    (lazy-print stream n)))

;; =======================
;; Sequence of integer numbers
;; =======================

(defn integers-from (n)
  (lazy-cons n (integers-from (1+ n))))

(def *integers-seq* (integers-from 1))


;; =======================
;; Sequence of Fibonacci and Lucas numbers
;; =======================

(letrec ((fib-gen (a b)
           (lazy-cons a (fib-gen b (+ a b)))))
  (def *fibonacci-seq* (fib-gen 1 1))
  (def *lucas-seq*     (fib-gen 2 1)))

;; =======================
;; Sequence of primes using "sieve" of Erathostenes
;; =======================

(defn integer-division (a b)
  (number-coerce
   (/ (number-coerce a 'integer)
      (number-coerce b 'integer))
   'integer))

(defn remainder (a b)
  (let* ((div (integer-division a b))
         (intdiv (- a (* div b))))
    intdiv))

(defn divisiblep (x y)
  (zerop (remainder x y)))

(letrec ((sieve (stream)
           (lazy-cons
            (lazy-car stream)
            (sieve (lazy-filter
                    (fn (x)
                      (not (divisiblep x
                             (lazy-car stream))))
                    (lazy-cdr stream))))))
  (def *primes-seq* (sieve (integers-from 2))))

;; -*- mode: lisp; mode: majestic; -*-

;; Add set
(def eval.
  (fn (exp env)
    (cond
     ((numberp exp) exp)
     ((stringp exp) exp)
     ((primitivep exp) exp)
     ((symbolp exp)
      (lookup. exp env))
     ((eq (first exp) 'quote)
      (second exp))
     ((eq (first exp) 'fn)
      (list 'closure (rest exp) env))
     ((eq (first exp) 'cond)
      (evcond. (rest exp) env))
     ((eq (first exp) 'def)
      (define. (second exp) (third exp) env))
     ((eq (first exp) 'do)
      (first (last (evlist. (rest exp) env))))
     ((eq (first exp) 'apply)
      (apply (second exp) (third exp)))
     (t (apply. (eval. (first exp) env)
                (evlist. (rest exp) env))))))

;; Review usage of "apply"
(def apply.
  (fn (proc args)
    (cond
     ((primitivep proc) (apply proc args))
     ((eq (first proc) 'closure)
      (eval. (second (second proc))
             (bind. (first (second proc))
                    args
                    (third proc))))
     (t (err "Undefined procedure: {}" proc)))))

(def evlist.
  (fn (L env)
    (cond
     ((nilp L) nil)
     (t (cons (eval. (first L) env)
              (evlist. (rest L) env))))))

(def evcond.
  (fn (clauses env)
    (cond
     ((nilp clauses) nil)
     ((eq (first-of-first clauses) t)
      (eval. (second (first clauses)) env))
     ((nilp (eval. (first-of-first clauses) env))
      (evcond. (rest clauses) env))
     (t (eval. (second (first clauses)) env)))))

(def bind.
  (fn (vars vals env)
    (cons (pair-up. vars vals)
          env)))

(def pair-up.
  (fn (vars vals)
    (cond
     ((nilp vars)
      (cond ((nilp vals) nil)
            (t (err "Too many arguments"))))
     ((nilp vals)
      (err "Too few arguments"))
     (t (cons (cons (first vars)
                    (first vals))
              (pair-up. (rest vars)
                        (rest vals)))))))

(def unboundp.
  (fn (x) (eq 'unbound-variable x)))

;; Simplify using recursion!
(def lookup.
  (fn (sym env)
    ((fn (local-lookup)
       (cond
        ((unboundp. local-lookup)
         ((fn (global-lookup)
            (cond
             ((unboundp. global-lookup)
              (err "Unbound variable: {}" sym))
             (t global-lookup)))
          (lookup-lexical. sym <E0>)))
        (t local-lookup)))
     (lookup-lexical. sym env))))

;; Lexical lookup
(def lookup-lexical.
  (fn (sym env)
    (cond
     ((nilp env) 'unbound-variable)
     (t ((fn (vcell)
           (cond
            ((nilp vcell)
             (lookup. sym (rest env)))
            (t (rest vcell))))
         (assq. sym (first env)))))))

(def assq.
  (fn (sym alist)
    (cond ((nilp alist) nil)
          ((eq sym (first (first alist)))
           (first alist))
          (t (assq. sym (rest alist))))))

;; Global environment
(def <E0>
  (list
   (list (cons '+              +)
         (cons '-              -)
         (cons '*              *)
         (cons '/              /)
         (cons '=              =)
         (cons 'numberp        numberp)
         (cons 'symbolp        symbolp)
         (cons 'stringp        stringp)
         (cons 'first          first)
         (cons 'second         second)
         (cons 'rest           rest)
         (cons 'third          third)
         (cons 'err            err)
         (cons 'first-of-first first-of-first)
         (cons 'primitivep     primitivep)
         (cons 'cons           cons)
         (cons 'last           last)
         (cons 'eq             eq)
         (cons 'nilp           nilp)
         (cons 'list           list))))

;; Extra
(def define.
  (fn (sym val env)
    (if (symbolp sym)
        (let ((val (eval. val env)))
          (if (errorp val)
              val
            (do (set <E0> (cons (list (cons sym val))
                                <E0>))
                sym)))
      (err "Not a symbol: {}" sym))))


;;;; Tests
(defn metacircular-evaluator-test ()
  (print "Metacircular evaluator test:")
  (mapc (fn (expression)
            (print "  > {}\n    {}"
                   expression
                   (eval. expression nil)))
        '(1
          (quote foo)
          (def *mynum* 7)
          (def square (fn (x) (* x x)))
          square
          (square 6)
          (square *mynum*)
          (cond ((nilp 1)
                 (quote nay))
                (t (quote okay)))
          (cond ((eq (= 1 1) t)
                 (quote okay))
                (t (quote nay)))
          ((fn (a b) (list a b))
           1 2)
          ((fn (x) (* x x)) 5)
          ((fn (x) (* x x)) *mynum*)
          (+ *mynum* *mynum*)
          (((fn (x) (fn (y) (+ x y))) 3) 4))))

;; -*- mode: lisp; mode: majestic; -*-

(def link list)
(def link-l first)
(def link-g second)
(def link-r third)
(def link-e fourth)
(def link-n (fn (x) (car (cddr (cddr x)))))

(defn back5 (l g r e n)
  (if (and (consp g)
           (consp r))
      (prove5 l g (rest r) e n)
      (prove5 (link-l l)
              (link-g l)
              (rest (link-r l))
              (link-e l)
              (link-n l))))

(defn prove5 (l g r e n)
  (cond ((nilp g)
         (print-frame e)
         (back5 l g r e n))
        ((nilp r)
         (if (nilp l)
             t
             (back5 l g r e n)))
        (t (let* ((a  (copy. (first r) n))
                  (e* (unify (first a)
                             (first g)
                             e)))
             (if e*
                 (prove5
                  (link l g r e n)
                  (append (rest a) (rest g))
                  db
                  e*
                  (1+ n))
                 (back5 l g r e n))))))

;; =====

(def link-c (fn (x) (cadr (cddr (cddr x)))))

(defn clear-r (x)
  (set-car (cddr x) '(())))

(defn back6 (l g r e n c)
  (cond ((and (consp g)
              (consp r))
         (prove6 l g (rest r) e n c))
        ((consp l)
         (prove6 (link-l l)
                 (link-g l)
                 (rest (link-r l))
                 (link-e l)
                 (link-n l)
                 (link-c l)))
        (t nil)))

(defn prove6 (l g r e n c)
  (cond ((nilp g)
         (print-frame e)
         (back6 l g r e n c))
        ((eq '! (first g))
         (clear-r c)
         (prove6 c (rest g) r e n c))
        ((eq 'r! (first g))
         (prove6 l (rest-of-rest g) r e n
                 (second g)))
        ((nilp r)
         (if (nilp l)
             t
             (back6 l g r e n c)))
        (t
         (let* ((a  (copy. (first r) n))
                (e* (unify (first a)
                           (first g)
                           e)))
           (if e*
               (prove6
                (link l g r e n c)
                (append (rest a)
                        `(r! ,l)
                        (rest g))
                db
                e*
                (1+ n)
                l)
               (back6 l g r e n c))))))

;; =====

(def empty '((bottom)))
(def var '?)
(def name second)
(def time rest-of-rest)

(defn eqv (x y)
  (or (eq x y)
      (and (numberp x)
           (numberp y)
           (= x y))))

(defn varp (x)
  (and (consp x)
       (eq var (first x))))

(defn lookup (v e)
  (let ((ident (name v))
        (tm    (time v)))
    (letrec
        ((loop (e)
             (cond ((not (consp (first-of-first e)))
                    nil)
                   ((and
                     (eq  ident (name (first-of-first e)))
                     (eqv tm    (time (first-of-first e))))
                    (first e))
                   (t (loop (rest e))))))
      (loop e))))

(defn value (x e)
  (if (varp x)
      (let ((v (lookup x e)))
        (if v
            (value (second v) e)
            x))
      x))

(defn copy. (x n)
  (cond ((not (consp x)) x)
        ((varp x) (append x n))
        (t (cons (copy. (first x) n)
                 (copy. (rest x) n)))))

(defn bind (x y e)
  (cons (list x y) e))

(defn unify (x y e)
  (let ((x (value x e))
        (y (value y e)))
    (cond ((eq x y) e)
          ((varp x) (bind x y e))
          ((varp y) (bind y x e))
          ((or (not (consp x))
               (not (consp y)))
           nil)
          (t (let ((e* (unify (first x)
                              (first y)
                              e)))
               (and e*
                    (unify (rest x)
                           (rest y)
                           e*)))))))

(defn resolve (x e)
  (cond ((not (consp x)) x)
        ((varp x)
         (let ((v (value x e)))
           (if (varp v)
               v
               (resolve v e))))
        (t (cons
            (resolve (first x) e)
            (resolve (rest x) e)))))

(defn print-frame (e)
  (letrec
      ((loop ((first-ee . rest-ee))
          (when (consp rest-ee)
            (when (nilp (time (first first-ee)))
              (print "{} = {}"
                     (second (first first-ee))
                     (resolve (first first-ee) e)))
            (loop rest-ee))))
    (loop e)
    (terpri)))

;; =============

(def db nil)
(def goals nil)

(defn prove5-example ()
  (let ((db
         '(((edge a b))
           ((edge a f))
           ((edge a g))
           ((edge b c))
           ((edge b d))
           ((edge c d))
           ((edge c e))
           ((edge g h))
           ((edge d h))
           ((edge h e))
           ((edge h f))
           
           ((path (? A) (? B)
             ((? A) (? B)))
            (edge (? A) (? B)))
           
           ((path (? A) (? B)
             ((? A) . (? CB)))
            (edge (? A) (? C))
            (path (? C) (? B) (? CB)))
           
           ((tasty bananas))
           ((tasty bread))
           ((tasty chocolate))
           ((healthy bananas))
           ((healthy porridge))
           ((healthy bread))
           
           ((likes john (? X))
            (healthy (? X))
            (tasty (? X)))))
        (goals '(((likes john (? X)))
                 ((path a f (? P))))))
    (print "==> prove5 examples")
    (print "Database:")
    (pretty-display db)
    (terpri)
    (mapc
     (fn (goal)
         (print "Goal: {}" goal)
         (print "Ans:  {}\n====="
                (prove5 '() goal db empty 1)))
     goals)))

;; ==================

(defn prove6-example ()
  (let ((db
         '(((exists foo)) ; exists(foo).
           ((exists bar)) ; exists(bar).
           ((exists baz)) ; exists(baz).
           ;; eq(X, X).
           ((eq (? X) (? X)))
           ;; neq(X, Y) :- eq(X, Y), !, fail.
           ((neq (? X) (? Y))
            (eq (? X) (? Y)) ! fail)
           ;; neq(X,Y).
           ((neq (? X) (? Y)))))
        (goals
         '(;; exists(X), exists(Y), neq(X, Y).
           ((exists (? X))
            (exists (? Y))
            (neq (? X) (? Y)))
           ;; bagof(X, exists(X), Bag).
           ((exists (? X))))))
    (print "==> prove6 examples")
    (print "Database:")
    (pretty-display db)
    (terpri)
    (mapc
     (fn (goal)
         (print "Goal: {}" goal)
         (print "Ans:  {}\n====="
                (prove6 '() goal db empty 1 '())))
     goals)))

;; ======

(defn run-examples ()
  (prove6-example)
  (prove5-example))