arthur/beluga
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases 7 Wiki Activity

adding lisp-interpreter
Meson Build and Deploy / build (push) Failing after 29s
Details

Browse Source
This commit is contained in:
Arthur Barraux
2025-09-24 10:58:09 +02:00
parent ab482df604
commit d8fc7d2d67
57 changed files with 30702 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files
lisp-interpreter/tests/code/8.scm
+47
View File
@@ -0,0 +1,47 @@
(define large-num (string-append
"73167176531330624919225119674426574742355349194934"
"96983520312774506326239578318016984801869478851843"
"85861560789112949495459501737958331952853208805511"
"12540698747158523863050715693290963295227443043557"
"66896648950445244523161731856403098711121722383113"
"62229893423380308135336276614282806444486645238749"
"30358907296290491560440772390713810515859307960866"
"70172427121883998797908792274921901699720888093776"
"65727333001053367881220235421809751254540594752243"
"52584907711670556013604839586446706324415722155397"
"53697817977846174064955149290862569321978468622482"
"83972241375657056057490261407972968652414535100474"
"82166370484403199890008895243450658541227588666881"
"16427171479924442928230863465674813919123162824586"
"17866458359124566529476545682848912883142607690042"
"24219022671055626321111109370544217506941658960408"
"07198403850962455444362981230987879927244284909188"
"84580156166097919133875499200524063689912560717606"
"05886116467109405077541002256983155200055935729725"
"71636269561882670428252483600823257530420752963450"))
(define width 13)
(define (char->number c)
(if (char-numeric? c)
(- (char->integer c) (char->integer #\0))
-1))
(define (substring->numbers subs)
(map char->number (string->list subs)))
(define (iter i largest)
(if (>= (+ i width) (string-length large-num))
largest
(let* ((sub (substring large-num i (+ i width)))
(set (substring->numbers sub))
(product (apply * set)))
(if (> product (car largest))
(iter (+ i 1) (cons product set))
(iter (+ i 1) largest)))))
(display (iter 0 '(-1 . '())))
lisp-interpreter/tests/code/bugs.scm
+56
View File
@@ -0,0 +1,56 @@
; add a test for every bug that is incountered
; to avoid recreating it in the future
; test basic vector creation and operations
(define v #(1 2 3 4 5 6 7 8 9 10))
(define (sum-to-n n) (/ (* n (+ n 1)) 2))
(define (sum-vector v)
(define (iter sum i)
(if (= i (vector-length v))
sum
(iter (+ sum (vector-ref v i)) (+ i 1))))
(iter 0 0))
(display "Sum to 10: ")
(display (sum-vector v))
(newline)
(assert (= (sum-to-n 10) (sum-vector v)))
; procedures with no arguments don't expand properly
(define (hello-world) (display "hello world") (newline))
(hello-world)
; vector and list assoc
(assert
(= (do ((i 1 (+ i 1)) (n 0 n))
((> i 10) n)
(set! n (+ i n)))
(* 5 11)))
(let ((sym (gensym)))
(assert (eq? sym sym)))
(assert (equal? (cons 2000 1) (cons 2000 1)))
(assert (equal? "apple" "apple"))
(assert (not (eq? 'DEFINE 'DEFINE-MACRO)))
(define (scope-test var)
(let ((var "dog"))
(==> var "dog"))
(==> var "cat"))
(scope-test "cat")
(define (scope-test-named var)
(let block-name ((var "dog"))
(==> var "dog"))
(==> var "cat"))
(scope-test-named "cat")
lisp-interpreter/tests/code/dp.scm
+59
View File
@@ -0,0 +1,59 @@
; PROBLEW
; W - maximum bag weight
; {m_1, m_2, ... m_n} = item weights
; {v_1, v_2, ... v_n} = item values
; want to choose a subset I so that
; sum m_i <= W
; and
; sum v_i is maximized
; In other words, if we choose another subset J
; then sum v_j <= sum v_i
(define (rand-item max-weight max-cost)
(cons (random max-weight)
(random max-cost)))
(define (build-items n)
(if (= n 0)
'()
(cons (rand-item 100 100)
(build-items (- n 1)))))
;(random-seed! (GET-UNIVERSAL-TIME))
;(define items (build-items 10))
(define items '((23 . 505) (26 . 352) (18 . 220) (32 . 354) (27 . 414) (29 . 498) (26 . 545) (30 . 473) (27 . 543)))
(define (knapsack remaining items)
(if (or (null? items) (<= remaining 0))
0
(let ((weight (car (car items)))
(val (cdr (car items))))
(max
(if (>= (- remaining weight) 0)
(+ val (knapsack (- remaining weight) (cdr items)))
0)
(knapsack remaining (cdr items))))))
(display (knapsack 67 items))
(assert (= (knapsack 67 items) 1270))
; https://en.wikipedia.org/wiki/Levenshtein_distance
(define (edit-distance-list a b eq?)
(cond ((null? a) (length b))
((null? b) (length a))
(else (min
(+ 1 (edit-distance-list (cdr a) b eq?)) ; insert
(+ 1 (edit-distance-list a (cdr b) eq?)) ; delete
(+
(if (eq? (car a) (car b)) 0 1) ; replace if needed
(edit-distance-list (cdr a) (cdr b) eq?))))))
(define (edit-distance a b)
(edit-distance-list (string->list a) (string->list b) char=?))
(==> (edit-distance "kitten" "sitting") 3)
lisp-interpreter/tests/code/draw-tree.scm
+5
View File
@@ -0,0 +1,5 @@
(load "include/draw-tree.scm")
(dt '(a b c (d e f (g . h))))
(dt '((a) (b . c) (d e)))
lisp-interpreter/tests/code/forms.scm
+93
View File
@@ -0,0 +1,93 @@
; copy examples from MIT scheme documentation and add related ones.
; Conditionals
; https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Conditionals.html
(assert (and (= 2 2) (> 2 1)))
(assert (and))
(==> (and 3 2) 2)
(==> (and 1 2 'c '(f g)) (f g))
(==> (or #f #\a #f) #\a)
(==> (or (memq 'b '(a b c)) (/ 3 0)) (b c))
(define (bit-type x)
(cond ((= x 0) 'OFF)
((= x 1) 'ON)
(else 'UNKNOWN)))
(==> (bit-type 0) OFF)
(==> (bit-type 1) ON)
(==> (bit-type 25) UNKNOWN)
; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_13.html
; Universl Time https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Universal-Time.html
(assert (integer? (get-universal-time)))
; https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Procedure-Operations.html#Procedure-Operations
(assert (procedure? (lambda (x) x)))
(assert (compound-procedure? (lambda (x) x)))
(assert (not (compiled-procedure? (lambda (x) x))))
(assert (not (procedure? 3)))
(assert (= 18 (apply + (list 3 4 5 6))))
(assert (compiled-procedure? eval))
(let ((x "hello")
(y "world"))
(==> (string-append x y) "helloworld"))
(let* ((x 2)
(y (+ x 1)))
(==> (+ x y) 5))
(do ((i 0 (+ i 1)))
((>= i 10))
(assert (>= i 0))
(display i))
(==> (eval '(+ 2 2)) 4)
(==> (eval '(+ 2 2) (interaction-environment)) 4)
(assert (scheme-report-environment 5))
(assert (case (+ 2 3)
((2) #f)
((1 5) #t)))
(assert (case 7
((2) #f)
((1 5) #f)
(else #t)))
(assert (case 2
((2) #t)
((1 5) #f)
(else #f)))
(assert (letrec ((even?
(lambda (n)
(if (zero? n)
#t
(odd? (- n 1)))))
(odd?
(lambda (n)
(if (zero? n)
#f
(even? (- n 1))))))
(even? 88)))
(let ((x 0))
(inc! x)
(==> x 1)
(dec! x)
(==> x 0))
(let ((x 'A) (y 'B))
(swap! x y)
(==> x B)
(==> y A))
lisp-interpreter/tests/code/gc.scm
+37
View File
@@ -0,0 +1,37 @@
(let ((y "happy days")
(z #(1 2 3)))
(gc-flip)
(assert (string=? y "happy days"))
(assert (equal? z (vector 1 2 3))))
(let ((x 'HELLO)
(v #( HELLO ) ))
(display v)
(assert (eq? x (vector-ref v 0)))
(gc-flip)
(assert (eq? x (vector-ref v 0))))
(define counter 500)
(define big-vector '())
(define (basic-loop)
(begin
(set! big-vector (make-vector 200 0))
(set! counter (- counter 1))
(vector-fill! big-vector counter)
(gc-flip)
(assert (= (vector-ref big-vector 3) counter))
(if (> counter 0)
(basic-loop)
'())
) )
(basic-loop)
(==> (call/cc (lambda (throw) (define x '(1 2 3)) (gc-flip) (throw x))) (1 2 3))
(print-gc-statistics)
lisp-interpreter/tests/code/hash_table.scm
+29
View File
@@ -0,0 +1,29 @@
(define h (make-hash-table))
(assert (hash-table? h))
(hash-table-set! h 2000 1)
(assert (equal? (list (cons 2000 1)) (hash-table->alist h)))
(hash-table-set! h 2001 2)
(assert (equal? -1 (hash-table-ref h 3000 -1)))
(assert (equal? 1 (hash-table-ref h 2000 -1)))
(assert (equal? 2 (hash-table-ref h 2001 -1)))
(define h2 (alist->hash-table (hash-table->alist h)))
(assert (equal? -1 (hash-table-ref h2 3000 -1)))
(assert (equal? 1 (hash-table-ref h2 2000 -1)))
(assert (equal? 2 (hash-table-ref h2 2001 -1)))
(define h3 (alist->hash-table '((APPLE . "apple") (PEAR . "pear") (BANANA . "banana"))))
(assert (equal? "apple" (hash-table-ref h3 'APPLE)))
(assert (equal? "pear" (hash-table-ref h3 'PEAR)))
(assert (equal? '() (hash-table-ref h3 'HASH)))
lisp-interpreter/tests/code/include/draw-tree.scm
+160
View File
@@ -0,0 +1,160 @@
; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2009-2012
; Placed in the Public Domain
;
; (draw-tree object) ==> unspecific
; (dt) ==> unspecific
;
; Print a tree structure resembling a Scheme datum. Each cons
; cell is represented by [o|o] with lines leading to their car
; and cdr parts. Conses with a cdr value of () are represented
; by [o|/].
;
; DT is an abbrevation for DRAW-TREE.
;
; (Example): (draw-tree '((a) (b . c) (d e))) ==> unspecific
;
; Output: [o|o]---[o|o]---[o|/]
; | | |
; [o|/] | [o|o]---[o|/]
; | | | |
; a | d e
; |
; [o|o]--- c
; |
; b
(define (draw-tree n)
(define *nothing* (cons 'N '()))
(define *visited* (cons 'V '()))
(define (empty? x) (eq? x *nothing*))
(define (visited? x) (eq? (car x) *visited*))
(define (mark-visited x) (cons *visited* x))
(define (members-of x) (cdr x))
(define (done? x)
(and (pair? x)
(visited? x)
(null? (cdr x))))
(define (draw-fixed-string s)
(let* ((b (make-string 8 #\space))
(k (string-length s))
(s (if (> k 7) (substring s 0 7) s))
(s (if (< k 3) (string-append " " s) s))
(k (string-length s)))
(display (string-append s (substring b 0 (- 8 k))))))
(define (draw-atom n)
(cond ((null? n)
(draw-fixed-string "()"))
((symbol? n)
(draw-fixed-string (symbol->string n)))
((number? n)
(draw-fixed-string (number->string n)))
((string? n)
(draw-fixed-string (string-append "\"" n "\"")))
((char? n)
(draw-fixed-string (string-append "#\\" (string n))))
((eq? n #t)
(draw-fixed-string "#t"))
((eq? n #f)
(draw-fixed-string "#f"))
(else
(error "draw-atom: unknown type" n))))
(define (draw-conses n)
(let draw-conses ((n n)
(r '()))
(cond ((not (pair? n))
(draw-atom n)
(reverse! r))
((null? (cdr n))
(display "[o|/]")
(reverse! (cons (car n) r)))
(else
(display "[o|o]---")
(draw-conses (cdr n) (cons (car n) r))))))
(define (draw-bars n)
(let draw-bars ((n (members-of n)))
(cond ((not (pair? n)) '())
((empty? (car n))
(draw-fixed-string "")
(draw-bars (cdr n)))
((and (pair? (car n))
(visited? (car n)))
(draw-bars (members-of (car n)))
(draw-bars (cdr n)))
(else
(draw-fixed-string "|")
(draw-bars (cdr n))))))
(define (skip-empty n)
(if (and (pair? n)
(or (empty? (car n))
(done? (car n))))
(skip-empty (cdr n))
n))
(define (remove-trailing-nothing n)
(reverse (skip-empty (reverse n))))
(define (all-vertical? n)
(or (not (pair? n))
(and (null? (cdr n))
(all-vertical? (car n)))))
(define (draw-members n)
(let draw-members ((n (members-of n))
(r '()))
(cond ((not (pair? n))
(mark-visited
(remove-trailing-nothing
(reverse r))))
((empty? (car n))
(draw-fixed-string "")
(draw-members (cdr n)
(cons *nothing* r)))
((not (pair? (car n)))
(draw-atom (car n))
(draw-members (cdr n)
(cons *nothing* r)))
((null? (cdr n))
(draw-members (cdr n)
(cons (draw-final (car n)) r)))
((all-vertical? (car n))
(draw-fixed-string "[o|/]")
(draw-members (cdr n)
(cons (caar n) r)))
(else
(draw-fixed-string "|")
(draw-members (cdr n)
(cons (car n) r))))))
(define (draw-final n)
(cond ((not (pair? n))
(draw-atom n)
*nothing*)
((visited? n)
(draw-members n))
(else
(mark-visited (draw-conses n)))))
(if (not (pair? n))
(draw-atom n)
(let draw-tree ((n (mark-visited (draw-conses n))))
(if (not (done? n))
(begin (newline)
(draw-bars n)
(newline)
(draw-tree (draw-members n))))))
(newline))
(define dt draw-tree)
lisp-interpreter/tests/code/include/prolog.scm
+283
View File
@@ -0,0 +1,283 @@
; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 1998-2009
; Placed in the Public Domain
;
; (prolog list1 list2) ==> list
; (new-database!) ==> unspecific
; (fact! list) ==> unspecific
; (predicate! list1 list2 ...) ==> unspecific
; (query list) ==> list
;
; (load-from-library "prolog.scm")
;
; This is a tiny PROLOG interpreter that is based on an even
; tinier PROLOG interpreter written in MACLISP by Ken Kahn.
;
; The PROLOG procedures takes a query LIST1 and a database
; LIST2 as arguments, attempts to prove LIST1 in LIST2, and
; returns the result(s).
; NEW-DATABASE! sets up a fresh PROLOG database (thereby
; deleting any existing one).
;
; FACT! adds a new fact to the database.
;
; PREDICATE! adds a predicate with the head LIST1 and the
; clauses LIST2 ... to the database.
;
; QUERY attempts to prove LIST1. It returns a list of results.
; An empty list indicates that LIST1 could not be proven.
;
; See "prolog-test.scm" for an example program.
;
; The following macros add some syntactic sugar for interactive
; use; they allows you to write, for instance, (! (man socrates))
; instead of (fact! '(man socrates)).
;
; (! fact) ==> unspecific
; (:- list1 list2 ...) ==> unspecific
; (? query) ==> unspecific
;
; The following special predicates are implemented in the
; interpreter: (== A B) returns a new environment if A can be
; unified with B, else NO. (Dif A B) returns NO if A can be
; unified with B, else YES (use only at the end of a clause!)
;
; Example: (begin (! (man socrates))
; (:- (mortal ?x)
; (man ?x))
; (query '(mortal ?who))) ==> (((who . socrates)))
(define *prolog-database* '())
(define (prolog q db)
(define empty-env '((())))
(define top-scope "")
(define true '(()))
(define false '())
(define (unique a)
(letrec
((unique2
(lambda (a r)
(cond ((null? a)
(reverse! r))
((member (car a) r)
(unique2 (cdr a) r))
(else
(unique2 (cdr a)
(cons (car a) r)))))))
(unique2 a '())))
(define (variable? x)
(and (symbol? x)
(char=? #\? (string-ref (symbol->string x) 0))))
(define (internal? x)
(and (symbol? x)
(char=? #\: (string-ref (symbol->string x) 0))))
(define (anonymous? x)
(eq? '_ x))
(define (extend n v env)
(cons (cons n v) env))
(define (new-scope env id)
(cond ((variable? env)
(string->symbol
(string-append (symbol->string env) id)))
((pair? env)
(cons (new-scope (car env) id)
(new-scope (cdr env) id)))
(else
env)))
(define (new-env-id x)
(string-append ";" x))
(define (value-of x env)
(if (variable? x)
(let ((v (assq x env)))
(if v
(value-of (cdr v) env)
x))
x))
(define (unify x y env)
(let ((x (value-of x env))
(y (value-of y env)))
(cond ((variable? x) (extend x y env))
((variable? y) (extend y x env))
((or (anonymous? x)
(anonymous? y))
env)
((and (pair? x)
(pair? y))
(let ((new (unify (car x) (car y) env)))
(and new (unify (cdr x) (cdr y) new))))
((eq? x y) env)
(else #f))))
(define (check-args g n)
(if (not (= n (length g)))
(error "wrong number of arguments" g)))
(define (goal-unify rules goals env id result)
(check-args (car goals) 3)
(let* ((this-goal (car goals))
(new-env (unify (cadr this-goal) (caddr this-goal) env)))
(if new-env
(let ((r (prove (cdr goals)
new-env
(new-env-id id))))
(try-rules (cdr rules) goals env id (append result r)))
(try-rules (cdr rules) goals env id result))))
(define (goal-dif rules goals env id result)
(check-args (car goals) 3)
(let* ((this-goal (car goals))
(new-env (unify (cadr this-goal) (caddr this-goal) env)))
(if (not new-env)
(let ((r (prove (cdr goals)
env
(new-env-id id))))
(try-rules (cdr rules) goals env id (append result r)))
false)))
(define (goal* rules goals env id result)
(let* ((this-rule (new-scope (car rules) id))
(new-env (unify (car goals) (car this-rule) env)))
(if new-env
(let ((r (prove (append (cdr this-rule) (cdr goals))
new-env
(new-env-id id))))
(try-rules (cdr rules) goals env id (append result r)))
(try-rules (cdr rules) goals env id result))))
(define (try-rules rules goals env id result)
(if (null? rules)
result
(case (caar goals)
((==) (goal-unify rules goals env id result))
((dif) (goal-dif rules goals env id result))
(else (goal* rules goals env id result)))))
(define (list-env env)
(letrec
((this-id caar)
(scope-id caddr)
(top-level?
(lambda (x)
(not (memv #\; (string->list (symbol->string x))))))
(var-name
(lambda (x)
(let* ((s (symbol->string x))
(k (string-length s)))
(let loop ((i 0))
(if (or (>= i k)
(char=? #\; (string-ref s i)))
(string->symbol (substring s 1 i))
(loop (+ 1 i)))))))
(list-env2
(lambda (e r)
(cond ((null? (cdr e))
(list r))
((top-level? (this-id e))
(list-env2 (cdr e)
(extend (var-name (this-id e))
(value-of (this-id e) env)
r)))
(else
(list-env2 (cdr e) r))))))
(list-env2 env '())))
; version without memoization
(define (prove goals env id)
(if (null? goals)
(list-env env)
(try-rules db goals env id '())))
;(define proven (make-hash-table))
;(define (prove goals env id)
; (if (null? goals)
; (list-env env)
; (let* ((k (append goals env))
; (v (hash-table-ref proven k #f)))
; (if v
; (car v)
; (let ((v (try-rules db goals env id '())))
; (hash-table-set! proven k v)
; v)))))
(define (any? p a)
(cond ((null? a) #f)
((p (car a)) #t)
(else (any? p (cdr a)))))
(define (cleanup env)
(apply append
(map (lambda (frame)
(if (or (any? (lambda (x) (variable? (cdr x))) frame)
(any? (lambda (x) (internal? (cdr x))) frame))
'()
(list frame)))
env)))
(cleanup (unique (prove (new-scope q top-scope)
empty-env
(new-env-id top-scope)))))
(define (new-database!)
(set! *prolog-database* '()))
(define (update! x)
(set! *prolog-database*
(cons x *prolog-database*)))
(define (fact! x)
(let ((update! update!))
(update! (list x))))
(define (predicate! head . clause*)
(let ((update! update!))
(update! (cons head clause*))))
(define (query . q)
(prolog q (reverse *prolog-database*)))
(define (print-frames env)
(cond ((equal? '(()) env)
(display "yes")
(newline))
((equal? '() env)
(display "no")
(newline))
(else
(for-each (lambda (frame)
(for-each (lambda (b)
(display (car b))
(display " = ")
(display (cdr b))
(display "; "))
frame)
(newline))
env))))
(define-macro ! (lambda (fact) `(fact! (quote ,fact))))
(define-macro :- (lambda args
(cons 'PREDICATE! (map1 (lambda (entry) `(quote ,entry)) args))))
(define-macro ? (lambda args
(list 'PRINT-FRAMES
(cons 'QUERY (map1 (lambda (entry) `(quote ,entry)) args)))))
lisp-interpreter/tests/code/lists.scm
+69
View File
@@ -0,0 +1,69 @@
(assert '())
(==> (cons 'a (cons 'b (cons 'c '()))) (a b c))
(==> (car (cons 1 2)) 1)
(==> (cdr (cons 1 2)) 2)
(==> (car (list 1 2)) 1)
(==> (cdr (list 1 2)) (2))
(define test-pair (cons 1 2))
(set-car! test-pair 3)
(set-cdr! test-pair 4)
(==> test-pair (3 . 4))
(==> (reverse '(a b c)) (c b a))
; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_8.html
(assert (pair? '(a . b)))
(assert (pair? '(a b c)))
(assert (not (pair? '())))
(assert (not (pair? '#(a b))))
(assert (= (length '(a b c)) 3))
(assert (= (length '()) 0))
(assert (not (null? '(a b c))))
(assert (null? '()))
(assert (eq? (list-ref '(a b c d) 2) 'c))
(==> (append '(a) '(b c d)) (a b c d))
(==> (sort '(1 4 2 6 3) <) (1 2 3 4 6))
(==> (make-list 4 1) (1 1 1 1))
(==> (memq 'a '(a b c)) (a b c))
(==> (memq 'b '(a b c)) (b c))
(==> (memq 'a '(b c d)) #f)
(==> (member (list 'a) '(b (a) c)) ((a) c))
(==> (member 'a '(b (a) c)) #f)
(assert (= (apply + (list 3 4 5 6)) 18))
(==> (append-reverse! '("y" "x" "w") '("z")) ("w" "x" "y" "z"))
; Association lists
(define list-map '((bob . 1) (john . 2) (dan . 3) (alice . 4)))
(assert (= (cdr (assoc 'john list-map)) 2))
(assert (= (cdr (assoc 'alice list-map)) 4))
(assert (not (assoc 'bad-key list-map)))
(assert (= (cdr (assq 'john list-map)) 2))
(assert (= (cdr (assq 'alice list-map)) 4))
(assert (not (assq 'bad-key list-map)))
(assert (list? '(1 2)))
(assert (not (list? (cons 1 2))))
(==> (reduce + 0 '(1 2 3 4)) 10)
(==> (reduce + 0 '(1 2)) 3)
(==> (reduce + 0 '()) 0)
(==> (reduce list '() '(1 2 3 4)) (((1 2) 3) 4))
(==> (fold-left + 0 '(1 2 3 4)) 10)
(==> (fold-left list '() '(1 2 3 4)) ((((() 1) 2) 3) 4))
lisp-interpreter/tests/code/macros.scm
+33
View File
@@ -0,0 +1,33 @@
; QUASIQUOTE
(assert (equal? `(1 2 3) '(1 2 3)))
(let ((x 1))
(assert (equal? `(,x 2 3) '(1 2 3))))
(let ((x 'a))
(assert (equal? `(,x x ,x) '(a x a))))
; nil! macro
(define-macro nil! (lambda (x)
`(set! ,x '())))
(define x 3)
(assert (= x 3))
(nil! x)
(assert (null? x))
; ntimes macro
(define-macro ntimes (lambda (n . body)
(let ((i (gensym)))
(cons 'DO (cons `((,i 0 (+ ,i 1)))
(cons `((>= ,i ,n) '()) body))
))))
(define x 0)
(ntimes 10 (set! x (+ x 1)))
(assert (= x 10))
lisp-interpreter/tests/code/norvig.scm
+71
View File
@@ -0,0 +1,71 @@
; From Peter Norvig's Lispy tests
; http://norvig.com/lispy2.html
(define x 3)
(assert (= x 3))
(assert (= (+ x x) 6))
(assert (= (begin (define x 1) (set! x (+ x 1)) (+ x 1)) 3))
(assert (= ((lambda (x) (+ x x)) 5) 10))
(define twice (lambda (x) (* 2 x)))
(assert (= (twice 5) 10))
(define compose (lambda (f g) (lambda (x) (f (g x)))))
(assert (= (car ((compose list twice) 5)) 10))
(define repeat (lambda (f) (compose f f)))
(assert (= ((repeat twice) 5) 20))
(assert (= ((repeat (repeat twice)) 5) 80))
(define fact (lambda (n) (if (< n 2) 1 (* n (fact (- n 1))))))
(assert (= (fact 3) 6))
(define abs (lambda (n) ((if (> n 0) + -) 0 n)))
(assert (= (car (list (abs -3) (abs 0) (abs 3))) 3))
(define combine (lambda (f)
(lambda (x y)
(if (null? x) (quote ())
(f (list (car x) (car y))
((combine f) (cdr x) (cdr y)))))))
(define zip (combine cons))
(assert (= (car (cdr (assoc 3 (zip (list 1 2 3 4) (list 5 6 7 8))))) 7))
(define riff-shuffle (lambda (deck) (begin
(define take (lambda (n seq) (if (< n 1) (quote ()) (cons (car seq) (take (- n 1) (cdr seq))))))
(define drop (lambda (n seq) (if (< n 1) seq (drop (- n 1) (cdr seq)))))
(define mid (lambda (seq) (/ (length seq) 2)))
((combine append) (take (mid deck) deck) (drop (mid deck) deck)))))
(display (riff-shuffle (list 1 2 3 4 5 6 7 8)))
(newline)
(display ((repeat riff-shuffle) (list 1 2 3 4 5 6 7 8)))
(newline)
(display (riff-shuffle (riff-shuffle (riff-shuffle (list 1 2 3 4 5 6 7 8)))))
(newline)
(define fabs (lambda (n) ((if (> n 0.0) + -) 0.0 n)))
(define (newton guess function derivative epsilon)
(define guess2 (- guess (/ (function guess) (derivative guess))))
(if (< (fabs (- guess guess2)) epsilon) guess2
(newton guess2 function derivative epsilon)))
(define (square-root a)
(newton 1.0 (lambda (x) (- (* x x) a)) (lambda (x) (* 2.0 x)) 0.0001))
(display "sqrt(2)=")
(display (square-root 2.0))
(newline)
(display "sqrt(200)=")
(display (square-root 200.0))
(newline)
(==> (call/cc (lambda (throw) (+ 5 (* 10 (throw 1))))) 1)
(==> (call/cc (lambda (throw) (+ 5 (* 10 1)))) 15)
(==> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 (escape 3)))))))) 35)
(==> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 (throw 3)))))))) 3)
(==> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 1))))))) 1005)
(==> (let ((a 1) (b 2)) (+ a b)) 3)
lisp-interpreter/tests/code/numbers.scm
+82
View File
@@ -0,0 +1,82 @@
(==> (+ 2 2) 4)
(==> (+ (* 2 100) (* 1 10)) 210)
(==> (if (> 6 5) (+ 1 1) (+ 2 2)) 2)
(==> (if (< 6 5) (+ 1 1) (+ 2 2)) 4)
(==> (gcd 32 -36) 4)
(==> (gcd 4 3) 1)
(==> (gcd) 0)
(==> (lcm 32 -36) 288)
(assert (exact? (lcm 32 -36)))
(assert (inexact? (lcm 32.0 -36)))
(==> (lcm) 1)
(==> (abs -1) 1)
(==> (map + '(1 1 1) '(2 2 2)) (3 3 3))
(==> (map abs '(-1 -2 3)) (1 2 3))
(==> (vector-map abs #(-1 -2 3)) #(1 2 3))
(==> (- 1) -1)
(==> (- 436) -436)
(==> (- -7) 7)
(assert (integer? 3))
(assert (real? 3))
(assert (real? 3.5))
(assert (not (integer? 3.5)))
(assert (< 3 4))
(assert (> 4 3))
(assert (>= 4 3))
(assert (<= 3 4))
(assert (<= 1 1))
(assert (< -5 5))
(assert (not (> 3 4)))
(assert (= (modulo -13 4) 3))
(assert (= (remainder -13 4) -1))
(assert (= (remainder 13 -4) 1))
(assert (even? 2))
(assert (not (odd? 2)))
(assert (odd? 3))
(assert (odd? 7))
(assert (not (odd? 4)))
(assert (exact? (+ 1 2 3)))
(assert (inexact? (+ 1 2.5 3)))
(assert (inexact? (+ 1.3 2 3)))
(assert (exact? (* 1 2 3)))
(assert (inexact? (* 1 2.5 3)))
(assert (inexact? (* 1.3 2 3)))
(assert (exact? (- 1 2)))
(assert (inexact? (- 1 2.5)))
(assert (inexact? (- 1.3 2)))
(assert (exact? (expt 3 3)))
(==> (expt 3 3) 27)
(assert (inexact? (expt 3 2.5)))
(==> (magnitude 13) 13)
(==> (magnitude -13) 13)
(==> (floor 0.87) 0)
(==> (ceiling 0.87) 1)
(==> (round 0.87) 1)
(assert (< (- (abs (atan 0)) (/ 3.141592 4)) 0.001))
lisp-interpreter/tests/code/permute.scm
+21
View File
@@ -0,0 +1,21 @@
(define (brute max-length set)
(define (permute n)
(define str (make-string n))
(define (iter d)
(if (= d n)
(begin
(display str)
(display " "))
(do ((i 0 (+ i 1)))
((= i (string-length set)) 'done)
(begin
(string-set! str d (string-ref set i))
(iter (+ d 1))))))
(iter 0))
(do ((len 0 (+ len 1)))
((> len max-length) 'done)
(permute len)))
(brute 4 "abcd")
(newline)
lisp-interpreter/tests/code/prolog.scm
+5
View File
@@ -0,0 +1,5 @@
(include "include/prolog.scm")
(! (man socrates))
(:- (mortal ?x) (man ?x))
(? (mortal ?who))
lisp-interpreter/tests/code/sicp.scm
+158
View File
@@ -0,0 +1,158 @@
; A collection of SICP excercises
; these are all my solutions from reading
; the book
; 1.01 - basic expressions
(assert (= (+ (* 2 4) (- 4 6)) 6))
(define a 3)
(define b (+ a 1))
(assert (= (+ a b (* a b)) 19))
(assert (= (if (and (> b a) (< b (* a b)))
b
a) 4))
(assert (= (cond ((= a 4) 6)
((= b 4) (+ 6 7 a))
(else 25)) 16))
(assert (= (+ 2 (if (> b a) b a )) 6))
(assert (= (* (cond ((> a b) a)
((< a b) b)
(else -1))
(+ a 1)) 16))
; 1.03 - largest squares
(define (sqr x) (* x x))
(define (largest-squares x y z)
(cond ((and (< z x) (< z y)) (+ (sqr x) (sqr y)))
((and (< y x) (> y z)) (+ (sqr x) (sqr z)))
(else (+ (sqr y) (sqr z)))
))
(assert (= (largest-squares 3 4 5) (+ 25 16)))
(assert (= (largest-squares 3 5 4) (+ 25 16)))
; 1.14 change counter
(define (count-change amount) (cc amount 5))
(define (cc amount kinds-of-coins)
(cond ((= amount 0) 1)
((or (< amount 0) (= kinds-of-coins 0)) 0)
(else (+ (cc amount
(- kinds-of-coins 1))
(cc (- amount
(first-denomination kinds-of-coins))
kinds-of-coins)))))
(define (first-denomination kinds-of-coins)
(cond ((= kinds-of-coins 1) 1)
((= kinds-of-coins 2) 5)
((= kinds-of-coins 3) 10)
((= kinds-of-coins 4) 25)
((= kinds-of-coins 5) 50)))
(display "counting change: ")
(display (count-change 75))
(newline)
; 1.16 - fast powers
(define (exp-fast b n) (exp-iter b n 1))
(define (exp-iter b n product)
(cond ((= n 0) product)
; b^n = (b^2) n/2
((even? n) (exp-iter (* b b) (/ n 2) product))
; b^n = b * b^n-1
(else (exp-iter b (- n 1) (* product b)))))
(assert (= (exp-fast 5 4) 625))
(assert (= (exp-fast 2 8) 256))
; 1.17 - fast multiply
(define (double a) (+ a a))
(define (halve a) (/ a 2))
(define (fast-mul a b) (fast-mul-iter a b 0))
(define (fast-mul-iter a b sum)
(cond ((= b 0) sum)
((even? b) (fast-mul-iter (double a) (halve b) sum))
(else (fast-mul-iter a (- b 1) (+ sum a)))))
(assert (= (fast-mul 3 4) 12))
(assert (= (fast-mul 100 10) 1000))
; 1.19 fibonacci
(define (fib-helper n a b p q)
(cond
((= n 0) b)
((even? n) (fib-helper (/ n 2)
a
b
(+ (* p p) (* q q))
(+ (* 2 q p) (* q q ))
))
(else
(fib-helper
(- n 1)
(+ (* b q) (* a q) (* a p))
(+ (* b p) (* a q))
p
q))))
(define (fib n)
(fib-helper n 1 0 0 1))
(assert (= (fib 5) 5))
(assert (= (fib 7) 13))
(assert (= (fib 8) 21))
; 2.21 - square list
(define (square-list items)
(if (null? items)
items
(cons (* (car items) (car items)) (square-list (cdr items)))))
(define (square-list2 items)
(map (lambda (x) (* x x)) items))
(display (square-list (list 1 2 3 4)))
(newline)
(display (square-list2 (list 4 5 6 7)))
; bank accounts
(define (make-account val)
(lambda (action)
(if (eq? action 'deposit)
(lambda (n) (set! val (+ val n)))
(lambda (n) (set! val (- val n))))))
(define justin (make-account 100))
(define ryan (make-account 200))
((justin 'deposit) 20)
((ryan 'withdraw) 20)
(gc-flip)
(assert (= ((justin 'withdraw) 0) 120))
(assert (= ((ryan 'deposity) 0) 180))
; and or expansion
(let ((a 1))
(if (and (= a 0) (garbage here))
(assert 0)
'pass)
(if (or (= a 1) (garbage here))
'pass
(assert 0)))
lisp-interpreter/tests/code/streams.scm
+32
View File
@@ -0,0 +1,32 @@
(==> (force (delay (+ 1 2))) 3)
(==> (let ((p (delay (+ 1 2))))
(list (force p) (force p))) (3 3))
(assert (promise? (delay (+ 1 2))))
; promises computed at most once
(define count 0)
(define p
(delay
(begin
(set! count (+ count 1))
(* x 3))))
(define x 5)
(==> count 0)
(assert (promise? p))
(==> (force p) 15)
(assert (promise? p))
(==> count 1)
(==> (force p) 15)
(==> count 1)
(define (integers-starting-from n)
(cons-stream n (integers-starting-from (+ n 1))))
(assert (equal? (stream-head (integers-starting-from 0) 5) '(0 1 2 3 4)))
lisp-interpreter/tests/code/strings.scm
+60
View File
@@ -0,0 +1,60 @@
; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_7.html
; TODO: add characters to reader
(==> (make-string 10 #\x) "xxxxxxxxxx")
(assert (string? "Hi"))
(assert (not (string? 'Hi)))
(==> (string-length "") 0)
(==> (string-length "The length") 10)
(assert (string=? "PIE" "PIE"))
(assert (not (string=? "PIE" "pie")))
(==> (list->string (string->list "hello 123")) "hello 123")
(==> (string->list (list->string '(#\A #\B #\3))) (#\A #\B #\3))
; https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Symbols.html
(assert (symbol? 'foo))
(assert (symbol? (car '(a b))))
(assert (not (symbol? "bar")))
(assert (eq? 'foo (string->symbol "FOO")))
(assert (string=? "FLYING-FISH" (symbol->string 'flying-fish)))
; specials
(==> (string-length "\\") 1)
(==> (string-length "\t") 1)
(==> (string-length "\n") 1)
(==> (string-length "\f") 1)
(==> (string-length "\"") 1)
(display "Hello\nworld!")
(==> (string->number (number->string 279)) 279)
(==> (number->string (string->number "279")) "279")
(==> (string->number (number->string 0.5)) 0.5)
(assert (symbol<? 'A 'B))
(assert (not (symbol<? 'WALK 'DOG)))
(==> (- (char->integer #\c) (char->integer #\a)) 2)
(==> (string-ref "abc" 0) #\a)
(==> (string-ref "abc" 2) #\c)
(==> (string #\a #\b) "ab")
(==> (string) "")
(assert (char<? #\a #\b))
(assert (char<=? #\a #\a))
(assert (char-lower-case? #\a))
(assert (not (char-lower-case? #\A)))
(assert (not (char-upper-case? #\c)))
(assert (char-upper-case? #\C))
(assert (char-ci=? #\a #\A))
(assert (char-ci<? #\A #\b))
lisp-interpreter/tests/code/vectors.scm
+75
View File
@@ -0,0 +1,75 @@
(define v #(1 2 3))
(vector-swap! v 0 2)
(assert (= 3 (vector-ref v 0)))
(assert (= 1 (vector-ref v 2)))
(define (vec-sorted? v op)
; "if x and y are any two adjacent elements in the result,
; where x precedes y, it is the case that (procedure y x) ==> #f"
; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_8.html#SEC72
(or (< (vector-length v) 2)
(and (not (op (vector-ref v 1) (vector-ref v 0)))
(vec-sorted? (vector-tail v 1) op))))
; First make sure our sorted checker works
(assert (vec-sorted? #(1 2 2 4 5 6) <))
(assert (vec-sorted? #(1) <))
(assert (vec-sorted? #(1 2) <))
(assert (vec-sorted? #(7 6 5 4 3 2 1) >))
(assert (not (vec-sorted? #(2 1) <)))
(assert (not (vec-sorted? #(1 2 3 4 4 3) <)))
(assert (not (vec-sorted? #(1 2 3 2 4 5) <)))
; Now test the sort function
(assert (vec-sorted? (sort! #(1) <) <))
(assert (vec-sorted? (sort! #(2 1) <) <))
(assert (vec-sorted? (sort! #(1 2 3) <) <))
(assert (vec-sorted? (sort! #(3 8 1 7 2 9 4 5) <) <))
(assert (vec-sorted? (sort! #(1 2 3 4 5 6 7 8) <) <))
(assert (vec-sorted? (sort! #(3 8 1 7 2 9 4 5) >) >))
(assert (vec-sorted? (sort! #(1 2 3 4 5 6 7 8) >) >))
(assert (vec-sorted? (sort! #(92 59 30 57 74 78 43 33 77 10 78 83 76 49 42 94 82 70 15 11 90 86 44 70 39 64 69 30 59 95 15 79 13 54 98 82 42 96 79 17 56 93 20 1 84 72 75 19 74 43) >) >))
(assert (vec-sorted? (sort! #(92 59 30 57 74 78 43 33 77 10 78 83 76 49 42 94 82 70 15 11 90 86 44 70 39 64 69 30 59 95 15 79 13 54 98 82 42 96 79 17 56 93 20 1 84 72 75 19 74 43) <) <))
(assert (vec-sorted? (sort! #(3 8 1 7 2 9 4 5) <) <))
; Try other data types
(assert (vec-sorted? (sort! #(#\C #\B #\A #\D) char<?) char<?))
; Converting between lists and vectors
;https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Construction-of-Vectors.html
(==> (vector 'a 'b 'c) #(A B C))
(==> (list->vector '(dididit dah)) #(dididit dah))
; Binary search
(assert (= (vector-binary-search #(1 2 3 4 5) < (lambda (x) x) 3) 3))
(assert (not (vector-binary-search #(1 2 2 4 5) < (lambda (x) x) 3)))
(define v (vector 1 1 2))
(vector-fill! v 3)
(==> v #(3 3 3))
(==> (make-initialized-vector 5 (lambda (x) (* x x))) #(0 1 4 9 16))
(==> (vector-head #(1 2 3) 2) #(1 2))
; Issues parsing large vector
(define big-v #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200))
(==> (vector-length big-v) 200)
; Subvector
(==> (subvector #(1 2 3 4) 1 4) #(2 3 4))
(==> (subvector #(1 2 3 4) 0 2) #(1 2))
(==> (subvector #(A 1 A 1 A 1 A 1) 1 3) #(1 A))
; Association
(define avector #((bob . 1) (john . 2) (dan . 3) (alice . 4)))
(assert (= (cdr (vector-assq 'john avector)) 2))
(assert (= (cdr (vector-assq 'alice avector)) 4))
(assert (not (vector-assq 'bad-key avector)))
(sort! (make-initialized-vector 10000 (lambda (x) (random 1000000))) <)