Something almost Schemeish in something CLish.

I just wanted to see how much I could bang out in a single night without without referring to any documentation or previous code, and after having not even written anything in Common Lisp in 1.5 or 2 years. If I could have rememberd or bothered to look up more of CL’s standard lib and macros (like… iteration) this probably could have been done in a quarter of the time and space, but that wasn’t the point. Next up would be to implement define and revoke set!’s ability to create vars, making sure they scope correctly, and to add a list of primitives. But it’s time to go home. Maybe I’ll pick it up again tomorrow, maybe I won’t.

;Copyright (c) 2011 Matthew A. Martin (matt.a.martin@gmail.com)
;
;Permission is hereby granted, free of charge, to any person
;obtaining a copy of this software and associated documentation
;files (the "Software"), to deal in the Software without
;restriction, including without limitation the rights to use,
;copy, modify, merge, publish, distribute, sublicense, and/or sell
;copies of the Software, and to permit persons to whom the
;Software is furnished to do so, subject to the following
;conditions:
;
;The above copyright notice and this permission notice shall be
;included in all copies or substantial portions of the Software.
;
;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;OTHER DEALINGS IN THE SOFTWARE.
;;;;
; A scheme-flavored interpreter in a subset of Common Lisp.

(defconstant empty-stack nil)
(defconstant empty-frame nil)

;CL-USER> (frame (list 'a 'b 'c) (list 1 2 3) (frame (list 'd 'e 'f) (list 4 5 6) empty-frame))
;((A . 1) (B . 2) (C . 3) (D . 4) (E . 5) (F . 6))
(defun frame (vars vals frame)
  (if (null vars) frame
      (cons (cons (first vars) (first vals))
	    (frame (rest vars) (rest vals) frame))))

;CL-USER> (stack (frame (list 'a 'b 'c) (list 1 2 3) (frame (list 'd 'e 'f) (list 4 5 6) empty-frame)) empty-stack)
;(((A . 1) (B . 2) (C . 3) (D . 4) (E . 5) (F . 6)))
;CL-USER> (stack (frame (list 'a 'b 'c) (list 1 2 3) empty-frame) (stack (frame (list 'd 'e 'f) (list 4 5 6) empty-frame) empty-stack))
;(((A . 1) (B . 2) (C . 3)) ((D . 4) (E . 5) (F . 6)))
(defun stack (frame stack)
  (cons frame stack))

;CL-USER> (lookup-frame 'b (frame (list 'a 'b 'c) (list 1 2 3) empty-frame))
;(B . 2)
;CL-USER> (lookup-frame 'd (frame (list 'a 'b 'c) (list 1 2 3) empty-frame))
;NIL
(defun lookup-frame (var frame)
  (if (null frame) nil
      (if (eq var (first (first frame)))
          (first frame)
          (lookup-frame var (rest frame)))))

;CL-USER> (lookup 'a (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;(A . 1)
;CL-USER> (lookup 'b (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;(B . 2)
;CL-USER> (lookup 'c (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;(C . 3)
;CL-USER> (lookup 'd (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;NIL
(defun lookup (var stack)
  (if (null stack) nil
      (let ((varp (lookup-frame var (first stack))))
        (if varp varp
            (lookup var (rest stack))))))

(defun value (x)
  (rest x))

(defun update (var val stack)
  (let ((varp (lookup var stack)))
    (if varp 
	(rplacd varp val)
	(rplaca stack (frame (list var)
			     (list val)
			     (first stack)))))) ; Exploiting (first nil) => nil here

;;; From here on, nothing should care that envs/stacks and frames are lists.

;; Helper for evaluate.
;CL-USER> (defvar tststk (stack (frame (list 'a 'b) (list 1 2) empty-frame) (stack (frame (list 'c) (list 3) empty-frame) empty-stack)))
;TSTSTK
;CL-USER> (lookup-list (list 'a 'b 'c) tststk)
;(1 2 3)
;CL-USER> (lookup-list (list 'a 'b 'd 'c) tststk)
;(1 2 NIL 3)
(defun lookup-list (varlst stack)
  (if (null varlst) nil
      (cons (let ((varp (lookup (first varlst) stack)))
	      (if varp (value varp) varp))
	    (lookup-list (rest varlst) stack))))

;; Helper for evaluate.
(defun constant (x)
  (if (or (eq x t) (eq x nil) (numberp x))
      t
      nil))

;; Helper for evaluate.
;CL-USER> (func '((a b c) foo))
;(FN (A B C) (BEGIN FOO))
(defun func (args)
  (list 'fn ; tag 
	(first args) ; arg names 
	(cons 'begin ; implicit begin/progn
	      (rest args)))) ; fn body

;CL-USER> (fn-args (func '((a b c) foo)))
;(A B C)
(defun fn-args (x) (second x))

;CL-USER> (fn-body (func '((a b c) foo)))
;(BEGIN FOO)
(defun fn-body (x) (third x))

;; Helper for evaluate.
(defun eval-list (exps env)
  (if (null exps) nil
      (cons (evaluate (first exps) env)
	    (eval-list (rest exps) env))))

;; Helper for applier
(defun primitive? (x)
  (eq (first x) 'prim))
;; Helper for applier
(defun func? (x)
  (eq (first x) 'fn))

;CL-USER> (evaluate t tststk)
;T
;CL-USER> (evaluate '(if t b (quote bar)) tststk)
;2
;CL-USER> (evaluate '(if nil b (quote foo)) tststk)
;FOO
;CL-USER>  (evaluate '(begin 1 2 3 (eq? 2 2)) tststk)
;T
;CL-USER>  (evaluate '(set! a 4) tststk)
;(A . 4)
;CL-USER> tststk
;(((A . 4) (B . 2)) ((C . 3)))
;CL-USER>  (evaluate '(set! d 4) tststk)
;(((D . 4) (A . 4) (B . 2)) ((C . 3)))
;CL-USER> tststk
;(((D . 4) (A . 4) (B . 2)) ((C . 3)))
;CL-USER>  (evaluate '(set! a 5) tststk)
;(A . 5)
;CL-USER> tststk
;(((D . 4) (A . 5) (B . 2)) ((C . 3)))
;CL-USER>  (evaluate '(set! a b) tststk)
;(A . 2)
;CL-USER> tststk
;(((D . 4) (A . 2) (B . 2)) ((C . 3)))
;CL-USER>  (evaluate '(set! b 5) tststk)
;(B . 5)
;CL-USER> tststk
;(((D . 4) (A . 2) (B . 5)) ((C . 3)))
;CL-USER> (evaluate '(begin (set! foo (lambda (x) x)) (foo 1)) tststk)
;1
;CL-USER> (evaluate '(begin (set! bar (lambda (x) x)) (bar d)) tststk)
;4
;CL-USER> tststk
;(((BAR FN (X) (BEGIN X)) (FOO FN (X) (BEGIN X)) (D . 4) (A . 2) (B . 5)) ((C . 3)))
(defun evaluate (exp env)
  (cond
    ((constant exp) exp)
    ((symbolp exp) (rest (lookup exp env)))
    (t
     (let ((fn (first exp))
	   (args (rest exp)))
       (cond
	 ;; Special forms.
	 ((eq fn 'quote) (first args))
	 ((eq fn 'eq?) (eq (evaluate (first args) env) (evaluate (second args) env)))
	 ((eq fn 'if)
	  (let ((result (evaluate (first args) env)))
	    (if result
		(evaluate (second args) env)
		(evaluate (third args) env))))
	 ((eq fn 'lambda) (func args))
	 ((eq fn 'set!) ; or define
	  (update (first args) (evaluate (second args) env) env))
	 ((eq fn 'begin)
	  (if (eq 1 (length args))
	      (evaluate (first args) env)
	      ;; Borrow CL's progn here assuming it's iterative.
	      (progn (evaluate (first args) env)
		     (evaluate (cons 'begin (rest args)) env))))
	 (t (applier (evaluate fn env) (eval-list args env) env))))))) ; strict
	  
(defun applier (fn args env)
  (cond
    ((primitive? fn) (apply (second fn) args))
    ((func? fn) 
     (evaluate (fn-body fn)
	       (stack (frame (fn-args fn) args empty-frame)
		      env)))
    (t barf))) ; Shouldn't get here.

One more time!

Now we’re getting ugly. Hmmmmmm.

(define (onemoretime fails? lst func)
  
  ;; acc is usually the result of the
  ;; "reduce so far", here it is the
  ;; last pair in newlst. cur is
  ;; current item of consideration
  ;; in the original list. 
  (define (foo acc cur)
    ;; func should return a new
    ;; pair, which gets tacked
    ;; onto the end of newlst.
    (set-cdr! acc (func cur))
    ;; Have lfold push the new
    ;; pair into acc next
    ;; time it loops.
    (rest acc))

  (define (bar acc cur)
    ;; Here, func is allowed to 
    ;; return #f signalling to 
    ;; leave acc alone.
    (let ((tst (func cur)))
      (if tst
	  (begin (set-cdr! acc tst)
		 (rest acc))
	  acc)))

  ;; Grab pointer to first cons.
  ;; Contents of car will be dropped.
  ;; Contents of cdr will be clobbered. 
  (let ((newlst (list #f))) 
    (lfold (if fails? bar foo)
	   newlst ; Accumulator
	   lst) ; list we're deriving from
    (rest newlst))) ; car is trash, see above.

Examples so far:

(define (append hd tl)
  (onemoretime #f hd (lambda (nxt) 
                                   (cons nxt tl))))

(define (map func lst)
  (onemoretime #f lst (lambda (nxt) 
                                   (list (func nxt)))))

(define (filter pred? lst)
  (onemoretime #t lst (lambda (nxt)
			           (if (pred? nxt)
			               (list nxt)
			               #f))))

Update to my toy.

Function may return #f rather than cons, which will leave the list it’s building as is. Was needed for filter. Also slows it down a great deal. :[

(define (stillhasnoname lst func)
  ;; Grab pointer to first cons.
  ;; Contents of car will be dropped.
  ;; Contents of cdr will be clobbered. 
  (let ((newlst (list #f))) 
    ;; acc is usually the result of the
    ;; "reduce so far", here it is the
    ;; last pair in newlst. cur is
    ;; current item of consideration
    ;; in the original list. 
    (lfold (lambda (acc cur)
	     ;; func should return either 
	     ;; a new pair to be tacked 
	     ;; onto the end of newlst,
	     ;; or #f which will leave
	     ;; acc as-is. 
	     (let ((tst (func cur)))
	       (if tst
		   (begin (set-cdr! acc tst)
			  (rest acc))
		   acc)))
           newlst ; Accumulator
           lst) ; list we're deriving from
    (rest newlst))) ; car is trash, see above.

In case I want to grok this in 6 months.

(define (whatdoicallthis lst func)
  ;; Grab pointer to first cons.
  ;; Contents of car will be dropped.
  ;; Contents of cdr will be clobbered. 
  (let ((newlst (list #t))) 
    ;; acc is usually the result of the
    ;; "reduce so far", here it is the
    ;; last pair in newlis. cur is
    ;; current item of consideration
    ;; in the original list. 
    (lfold (lambda (acc cur)
	     ;; func should return a new
	     ;; pair, which gets tacked 
	     ;; onto the end of newlst.
	     (set-cdr! acc (func cur))
	     ;; Have lfold push the new
	     ;; pair into acc next
	     ;; time it loops.
	     (rest acc))
	   newlst ; Accumulator
	   lst) ; list we're deriving from
    (rest newlst))) ; car is trash, see above.

(define (append hd tl)
  (whatdoicallthis hd (lambda (nxt) 
			(cons nxt tl))))

(define (map func lst)
  (whatdoicallthis lst (lambda (nxt) 
			 (list (func nxt)))))

Woo!

Got it.

(define (whatdoicallthis lst func)
(let ((newlst (list list)))
(lfold (lambda (hd tl)
(set-cdr! hd (func tl))
(rest hd))
newlst
lst)
(rest newlst)))

(define (append hd tl)
(whatdoicallthis hd (lambda (nxt) (cons nxt tl))))

(define (map func lst)
(whatdoicallthis lst (lambda (nxt) (list (func nxt)))))

A step closer…

(define (append hd tl)
(let ((newlst (list list)))
(lfold (lambda (hd nxt)
(set-cdr! hd (cons nxt tl))
(rest hd))
newlst
hd)
(rest newlst)))

More dicking around. Stack friendly map.


(define (map func lst)
(if (null? lst) lst
(let ((newlis (list (func (first lst)))))
(let loop ((cur newlis) (lst (rest lst)))
(if (null? lst) newlis
(begin (set-cdr! cur (list (func (first lst))))
(loop (rest cur) (rest lst))))))))


Was trying to implement map with left fold. Wound up with this. The right fold implemention easily blows the stack in guile 1.8. Scheme48 copes perfectly well… with no perceptible difference in speed (which was basically instant) even with a 20k element list. Nice.

This works in both, though. I still have an hour to kill… hmm.

Late nights stuck at work on the weekends.

Fold gives me a hard on now. I’ll have to play with it more after some coffee. Think I’ll check out the reference implementation for SRFI 1, it looks like some sexy shit.


;;; Following along with:
; A tutorial on the universality and
; expressiveness of fold
; GRAHAM HUTTON
; University of Nottingham, Nottingham, UK
; http://www.cs.nott.ac.uk/-gmh
; J. Functional Programming 9 (4): 355–372, July 1999.
; Retreived from http://www.cs.nott.ac.uk/~gmh/fold.pdf

;; I use these at random.
(define first car)
(define second cadr)
(define head car)
(define tail cdr)
(define rest cdr)

;; fold, sum, product
;; Pg. 356(Journal)/2(PDF)
;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (fold func base lst)
; (if (null? lst)
; base
; (func (first lst) (fold func base (rest lst)))))
(let loop ((lst lst))
(if (null? lst)
base
(func (first lst) (loop (rest lst))))))

(define (sum lst)
;; Pg 13 recommends foldl, iterative.
(fold + 0 lst))

(define (product lst)
(fold * 1 lst))

;; Pg. 3
;; length, append, reverse, map, filter
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; fold (:) ys
(define (append hd tl)
;; This will share the tail.
;; (fold cons (fold cons tl '()) hd)) wouldn't,
;; but would still share (any (nested) lists).
(fold cons tl hd))

;; fold (λx n → 1 + n) 0
(define (length lst)
;; Remember that conceptually, fold is
;; (f (first lst) (fold f v (rest lst)))
;; so (length '(a b c)) basically becomes
;; (+ 1 (+ 1 (+ 1 0)))
(fold (lambda (hd tl) (+ 1 tl)) 0 lst))

;; fold (λx xs → xs + [x]) []
(define (reverse lst)
;; XXX This is shit.
; (fold (lambda (hd tl) (append tl (list hd))) (list) lst))
;; Improved, pg. 13.
;; foldl (λxs x → x : xs) []
(foldl (lambda (hd tl) (cons tl hd)) (list) lst))

;; fold (λx xs → f x : xs) []
(define (map func lst)
;; (map +1 '(1 2))
;; (cons (+1 1) (cons (+1 2) '()))
(fold (lambda (hd tl) (cons (func hd) tl)) (list) lst))

;; fold (λx xs → if p x then x : xs else xs) []
(define (filter pred? lst)
;; Haskell's syntax becomes appealing.
(fold (lambda (hd tl)
(if (pred? hd)
(cons hd tl)
tl))
(list)
lst))

;; Pg. 8
;; Sumlength
;;;;;;;;;;;;

;; fold (λn (x, y) → (n + x, 1 + y)) (0, 0)
(define (sumlength lst-of-nums)
; (fold (lambda (hd pair)
; (cons (+ hd (first pair))
; (+ 1 (second pair))))
; (cons 0 0)
; lst-of-nums))
;; Spew less interim garbage.
(fold (lambda (hd pair)
(set-car! pair (+ hd (first pair)))
(set-cdr! pair (+ 1 (rest pair)))
pair)
(cons 0 0)
lst-of-nums))

;; Pg 11.
;; compose
;;;;;;;;;;;;;;

;; fold (·) id
(define (compose lst)
(fold (lambda (fun1 fun2) ; dot
(lambda (x)
(fun1 (fun2 x))))
(lambda (x) x) ; id
lst))

;; Pg. 13
;; foldl
;;;;;;;;;

;; foldl f (f v x) xs
(define (foldl fun start lst)
; (if (null? lst)
; start
; (foldl fun
; (fun start (first lst))
; (rest lst))))
;; Don't keep passing fun around.
(let loop ((result start) (lst lst))
(if (null? lst)
result
(loop (fun result (first lst))
(rest lst)))))

(define (tst name result)
(if (not result)
(begin (display name)
(newline))))

(tst 'sum (= 15 (sum '(1 2 3 4 0 5))))
(tst 'rev (equal? '(baz (bar) foo)
(reverse '(foo (bar) baz))))
(tst 'app (equal? '(foo bar baz)
(append '(foo bar) '(baz))))
(tst 'len (= 3 (length '(a b c))))
(tst 'len (= 2 (length '(a '(b c)))))
(tst 'map (equal? '(1 2 3 4 5)
(map (lambda (x) (+ 1 x))
'(0 1 2 3 4))))
(tst 'filt (equal? '(2 4 6)
(filter even? '(1 2 3 3 5 7 4 599 99 6))))
(tst 'sumlen (equal? (cons 20 4) (sumlength '(2 4 6 8))))


Handy shit of the day: Lemon.

http://www.hwaci.com/sw/lemon/

“The Lemon program is an LALR(1) parser generator. [...] Both the source code to lemon itself and the code that lemon generates are in the public domain. [...] Lemon is maintained as part of the SQLite project. “

Why to give a shit in a nutshell, from the docs:

* In yacc and bison, the parser calls the tokenizer. In Lemon, the tokenizer calls the parser.
* Lemon uses no global variables. Yacc and bison use global variables to pass information between the tokenizer and parser.
* Lemon allows multiple parsers to be running simultaneously. Yacc and bison do not.

Go has been judged.

Switch “type” for “class” and “function” for “generic method” and it’s pretty much half of CLOS with some nice GC and CSP flavored concurrency written in a C-ish syntax.

More interestingly it looks like using the channels as continuations it’d be really easy to translate CPS code to, and I could definitely see something like termite being built atop it.

All in all it seems pretty fucking cool so far.