Skip to content

Commit

Permalink
Sharing the Crude for fun Lisp reduction machine
Browse files Browse the repository at this point in the history
  • Loading branch information
Gianfranco committed Mar 8, 2011
0 parents commit cf74c93
Showing 1 changed file with 331 additions and 0 deletions.
331 changes: 331 additions & 0 deletions LambdaMachine.lisp
@@ -0,0 +1,331 @@

;; This code is "as is", and may be used freely for educational purposes.
;; Copyright. Gianfranco Alongi
;;
;; Gianfranco Alongi presents LISP lambda expression machine 20081225
;;
;; LAMBDA (haskell style) MY-REPRESENTATION
;; ----------------------- ------------------------------------------
;; (\x . x ) (:l (:h x) (:b x))
;; (\x y z . x z ( x y )) (:l (:h x y z) (:b x z ( x y )
;; (\x . x (\y . y )) (:l (:h x) (:b x (:l (:h y) (:b y))))
;; (\x . ) (:l (:h x) (:b ) )
;; (\x . x x) (:l (:h x) (:b x x ))
;;
;; How to use this piece of LISP:
;;
;; (0) Load file into clisp.
;;
;; (1) Construct a lambda expression using the ml operator
;; Examples can be seen at end of file (standard combinators)
;;
;; (2) Use either of the functions together with appropriate arguments
;;
;; >>> LAMBDAEXPRESSION (LAMBDAEXPRESSIONS)
;; >> LAMBDAEXPRESSION VARIABLE/LAMBDAEXPRESSION
;; >>? LAMBDAEXPRESSION
;; >!>? LAMBDAEXPRESSION [VARIABLE/LAMBDAEXPRESSION]
;; !!! LAMBDAEXPRESSION
;;
;; [A] == A is optional
;;
;; >>> A (A_1...) Automatically reduces A using the list
;;
;; >> A B Reduces A with the help of B, returns result.
;;
;; >>? A Tries to perform a reduction on A, and returns
;; the reduced result or the input unchanged.
;;
;; >!>? A [B] Tries to reduce a (using a possible B) and
;; outputs the result in prettyprinted form
;; also returns result.
;;
;; !!! A Prettyprints the given lambdaexpression A.
;;
;; (3) Have fun! The example below shows the use of *twice* (predefined)
;; with the toy example ( twice ident ident 1 )
;;
;; (>!>? *twice*) <-- what you write
;; (\F X . F ( F X )) <-- what lisp responds with (ignoring return value)
;;
;; (>!>? (>!>? *twice*) *ident*)
;; (\X . (\X . X )((\X . X ) X ))
;;
;; (>!>? (>!>? (>!>? *twice*) *ident*) *ident*)
;; ((\X . X )((\X . X )(\X . X )))
;;
;; Here we must do a single internal reduction...
;; This is done by calling >!>? without additional arguments
;; As you can see here ------------------------------
;; |
;; v
;; (>!>? (>!>? (>!>? (>!>? *twice*) *ident*) *ident*))
;; ((\X . X )(\X . X ))
;;
;; Yet another internal reduction....
;;
;; (>!>? (>!>? (>!>? (>!>? (>!>? *twice*) *ident*) *ident*)))
;; (\X . X )
;;
;; Adding the final 1
;;
;; (>!>? (>!>? (>!>? (>!>? (>!>? (>!>? *twice*) *ident*) *ident*))) 1)
;; 1
;;
;; (4) A cooler example using the automatized reduction and list of arguments
;;
;; (eval (>>> *twice* `(,*twice* ,*inc* 0))) ;;<-- input to clisp prompt
;;
;; (\X . (\F X . F ( F X ))((\F X . F ( F X )) X ))
;; ((\F X . F ( F X ))((\F X . F ( F X ))(\X . ( + X 1 ))))
;; (\X . ((\F X . F ( F X ))(\X . ( + X 1 )))(((\F X . F ( F X ))(\X . ( + X 1 ))) X ))
;; (((\F X . F ( F X ))(\X . ( + X 1 )))(((\F X . F ( F X ))(\X . ( + X 1 ))) 0 ))
;; ((\X . (\X . ( + X 1 ))((\X . ( + X 1 )) X ))((\X . (\X . ( + X 1 ))((\X . ( + X 1 )) X )) 0 ))
;; ((\X . ( + X 1 ))((\X . ( + X 1 ))((\X . (\X . ( + X 1 ))((\X . ( + X 1 )) X )) 0 )))
;; ( + ((\X . ( + X 1 ))((\X . (\X . ( + X 1 ))((\X . ( + X 1 )) X )) 0 )) 1 )
;; ( + ( + ((\X . (\X . ( + X 1 ))((\X . ( + X 1 )) X )) 0 ) 1 ) 1 )
;; ( + ( + ((\X . ( + X 1 ))((\X . ( + X 1 )) 0 )) 1 ) 1 )
;; ( + ( + ( + ((\X . ( + X 1 )) 0 ) 1 ) 1 ) 1 )
;; ( + ( + ( + ( + 0 1 ) 1 ) 1 ) 1 )
;; 4
;;

(defun >>> (a &optional params)
"Atuomatically reduce a given lambda expression [a] as far as possible
using the given parameters [params]. Output the intermediate result in
each step"
(let* ((given (fixpoint 'simplify a)))
(cond ((or (atom given)
;; Reduced to single atom
(and (null params)
(equal given (>>? given)))
;; Consumed all input and no
;; further reduction possible
(and (not (lambdap given))
(equal (>!>? given) given))
;; Reduced to something not a lambda expr
;; and no further reduction possible
)
;; Return reduced ground form
given)

((and (> (length given) 1)
(not (lambdap given)))
;;Reduction from left possible
;;
(>>> (>!>? given) params))

((null params)
;;No more input parameter
;;
(if (equalp given (>>? given))
;;No more internal reduction possible
;;Output and return
(>!>? given)
;; More internal reduction possible
;;
(>>> (>!>? given))))

;; More input parameters
(t (if (lambdap given)
;; Given a lambda expression
;; consume input parameters
(>>> (>!>? given (car params)) (cdr params))
;; Otherwise perform internal reduction
;; until fixpoint
(if (equalp given (>>? given))
given
(>>> (>!>? given) params))))) ))

(defun fixpoint (op elem)
"Apply the operand <op> on the element <elem> until fixpoint
for <op> is reached"
(if (equal (funcall op elem) elem)
elem
(fixpoint op (funcall op elem))))

(defun >!>? (lambdaexpr &optional extra)
"Perform reduction and output at the same time.
Returns the result of the reduction."
(let ((given (fixpoint 'simplify lambdaexpr)))
(cond ((null extra)
(!!! (>>? given) )
(format t "~%")
(>>? given ))
(t (!!! (>> given extra))
(format t "~%")
(>> given extra)))))

(defun simplify (lambdaexpr)
"Simplify all expressions :: (e) ==> e"
(cond ((atom lambdaexpr)
lambdaexpr)
;;Done when it's just an atom
;;
((and (listp lambdaexpr)
(eq (length lambdaexpr) 1))
(car (mapcar 'simplify lambdaexpr)))
;; Mapcar on the lambdaexpression
(t (mapcar 'simplify lambdaexpr))))

(defun <$> (test elems pre)
"Process list pairwise, test pairs with test,
if succeed, return (pre elem1 elem2 rest) else nil"
(if (and (listp elems)
(> (length elems) 1))
(if (funcall test (car elems) (cadr elems))
`(,pre ,(car elems) ,(cadr elems) ,(cddr elems))
(<$> test (cdr elems) (append pre `(,(car elems))) ))
nil))

(defun ml (head body)
"Creates a lambda expression using a head and a body."
`(:l (:h ,@head) (:b ,@body)))

(defun x\y (x y l)
"Substitute all occurences of x with y in all levels of l
as long as element of l not is a lambdaexpr"
(cond ((lambdap l) l)
((atom l)
(if (eq x l) y l))
(t (mapcar (lambda (z) (x\y x y z)) l))))

(defun >>? (lambdaexpr)
"Searches for two lambda expressions and performs a reduction
if possible; otherwise it returns the same expression"
(if (atom lambdaexpr)
lambdaexpr
(let* ((x (<$> (lambda (x y) (lambdap x)) lambdaexpr ())))
(if (eq x nil)
(mapcar '>>? lambdaexpr)
(let* ((pre (car x))
(elem1 (cadr x))
(elem2 (caddr x))
(post (cadddr x)))
(append pre `(,(>> elem1 elem2)) post))))))

(defun >> (lambL lambR)
"Performs a beta reduction given a lambda expression and an expr reduces
(\x y z. y z) (\x.x) into (\y z. y z)"
(if (> (arity lambL) 0)
(let* ((vars (cdadr lambL))
(bound (first vars))
(newhead (cdr vars))
(newbody (x\y bound lambR (cdaddr lambL))))
(cond ((eq newhead nil)
(fixpoint 'simplify newbody))

;; If no more vaiables in lexprL can be bound
;; then new lambda expression is everything contained
;; within the substituted body
(T (ml newhead newbody))))
;; Arity of left lambdaexpr is 0, should be > 0.
(format t "Lexpr has arity == 0")))

(defun arity (lexpr)
"Returns the arity of the lambda expression, or nil"
(if (lambdap lexpr)
(length (cdadr lexpr)) nil))

(defun !!! (lexpr)
"Outputs a lambda expression in human readable form"
(cond ((atom lexpr)
;;Output a single variable or parenthesis
(format t " ~a " lexpr))

((lambdap lexpr)
;;Output the lambda expression
(format t "(")
(print-head (cadr lexpr))
(!!! (caddr lexpr))
(format t ")"))

((headp lexpr)
;;Output a head expr
(print-head lexpr))

((bodyp lexpr)
;;Output a body by outputting each (:b E E E)
;;as "(" .... "(" .. ")" .. ")"
(mapcar '!!! (cdr lexpr)))

((groupp lexpr)
;;Output each group ( x ( x y ) (z x y ))
;;as "( x ( x y ) ( z x y ))"
(format t "(")
(mapcar '!!! lexpr)
(format t ")"))))

(defun print-head (head-expr)
"Output a head expression in nice form. (:head X Y Z)"
(format t "\\")
(mapcar (lambda (x) (format t "~a " x)) (cdr head-expr))
(format t ". "))

(defun markp (lexpr mark)
(and (listp lexpr)
(eq (car lexpr) mark)))

(defun lambdap (lexpr)
(markp lexpr :l))

(defun headp (lexpr)
(markp lexpr :h))

(defun bodyp (lexpr)
(markp lexpr :b))

(defun groupp (lexpr)
"Check that this is a group == a list of expressions
without a preceding :b :l :h"
(and (listp lexpr)
(not (member (car lexpr) `(:b :l :h)))))

;; Some standard combinators +++++++++++++++++++++++++++++++++++++++++++++

;; identity
(defvar *ident* (ml `(x) `(x)))

;; K combinator
(defvar *k* (ml `(x y) `(x)))

;; K* combinator
(defvar *ks* (ml `(x y) `(y)))

;; S combinator
(defvar *s* (ml `(x y z) `(x z ( x y ))))

;; twice
(defvar *twice* (ml `(f x) `(f ( f x) )))

;; inc
(defvar *inc* (ml `(x) `(+ x 1)))

;; Church numerals
(defvar *zero* (ml `(f x) `(x)))
(defvar *succ* (ml `(n f x) `(f(n f x))))
(defvar *add* (ml `(n m f x) `(n f (m f x))))
(defvar *mult* (ml `(n m f) `(n ( m f))))

;; Some test
(defun tests ()
(list
`(,(format t "Add 0 with 0~%")
,(>>> *add* `(,*zero* ,*zero*))
,(format t "~%"))

`(,(format t "Multiply 0 with 0~%")
,(>>> *mult* `(,*zero* ,*zero*))
,(format t "~%"))

`(,(format t "Add 0 with 1~%")
,(>>> *add* `(,*zero* ,(>>> *succ* `(,*zero*))))
,(format t "~%"))

`(,(format t "Multuply 0 with 1~%")
,(>>> *mult* `(,*zero* ,(>>> *succ* `(,*zero*))))
,(format t "~%"))

`(,(format t "Multiply 1 with 1~%")
,(>>> *mult* `(,(>>> *succ* `(,*zero*)) ,(>>> *succ* `(,*zero*))))
,(format t "~%"))))

0 comments on commit cf74c93

Please sign in to comment.