Disabled external gits

cs420-acc/l3-compiler/examples/README.org

@@ -0,0 +1,34 @@
+#+OPTIONS: toc:nil author:nil
+#+TITLE: L3 examples
+
+This directory contains several example programs written in L3. The most important ones are briefly described in the table below.
+
+| Name    | Behavior                                                  |
+|---------+-----------------------------------------------------------|
+| bignums | Compute the factorial using "big integers"                |
+| life    | Conway's "Game of Life"                                   |
+| maze    | Inefficiently compute and draw a random maze              |
+| unimaze | Like maze, but more efficient and uses Unicode characters |
+| queens  | Solve the n-queens problem                                |
+| sudoku  | Solve a few Sudoku problems                               |
+|---------+-----------------------------------------------------------|
+
+Once the L3 compiler is complete, that is once it can generate L3A files for the L3 virtual machine, the examples above can be compiled in different ways, as described below.
+
+The first, but slowest technique is to execute the compiler from sbt, using the ~run~ command. For example, to compile the "unimaze" example, enter the following command at the sbt prompt (the ~>~ below represents the sbt prompt and should not be typed):
+: > run ../library/lib.l3m ../examples/unimaze.l3
+
+The second, faster technique consists in first packaging the L3 compiler and then executing it from the shell. The packaging should be done from sbt using the ~stage~ command, as follows:
+: > stage
+This generates a launcher script called ~l3~, which can be executed from the shell. For example, to compile the "unimaze" example as above, enter the following command in your shell, while in the ~examples~ directory (the ~$~ below represents the shell prompt and should not be typed):
+: $ ../compiler/target/universal/stage/bin/l3c \
+:     ../library/lib.l3m unimaze.l3
+
+Notice that both commands above will generate an L3 assembly file called ~out.l3a~. The name of that file can be changed using the ~l3.out-asm-file~ Java property. For example, to compile the same example as above but put the assembly file in ~unimaze.l3a~, enter the following at the shell prompt:
+: $ ../compiler/target/universal/stage/bin/l3c \
+:     -Dl3.out-asm-file=unimaze.l3a ../library/lib.l3m unimaze.l3
+
+To compile all the examples of this directory in parallel (to take advantage of a multi-core machine), a tool like [[https://savannah.gnu.org/projects/parallel/][GNU parallel]] can be used as follows:
+: $ ls *.l3                                                      \
+:     | parallel ../compiler/target/universal/stage/bin/l3c      \
+:                -Dl3.out-asm-file={.}.l3a ../library/lib.l3m {}

cs420-acc/l3-compiler/examples/bignums.l3

@@ -0,0 +1,65 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Basic computations (addition, multiplication and factorial) on big
+;; numbers. These are represented as lists of "digits" in the base
+;; specified below, in order of increasing weight.
+
+(def %base 10000)
+
+(def int->bignum list-make@1)
+
+(def bignum-print
+  (fun (b)
+    (let ((rev-b (list-reverse b)))
+      (int-print (list-head rev-b))
+      (list-for-each (fun (d)
+                          (if (< d 1000) (int-print 0))
+                          (if (< d 100) (int-print 0))
+                          (if (< d 10) (int-print 0))
+                          (int-print d))
+                     (list-tail rev-b)))))
+
+(def bignum-+
+     (fun (b1 b2)
+          (rec loop ((b1 b1) (b2 b2) (carry 0))
+               (cond ((list-empty? b1)
+                      (if (= 0 carry) b2 (loop (int->bignum carry) b2 0)))
+                     ((list-empty? b2)
+                      (if (= 0 carry) b1 (loop b1 (int->bignum carry) 0)))
+                     (#t
+                      (let ((res (+ (list-head b1) (list-head b2) carry)))
+                        (list-prepend (%t res %base)
+                                      (loop (list-tail b1)
+                                            (list-tail b2)
+                                            (/t res %base)))))))))
+
+(def bignum-scale
+     (fun (b n)
+          (rec loop ((b b) (n n) (carry 0))
+               (if (list-empty? b)
+                   (if (= 0 carry) list-empty (int->bignum carry))
+                   (let ((sh (+ (* (list-head b) n) carry)))
+                     (list-prepend (%t sh %base)
+                                   (loop (list-tail b) n (/t sh %base))))))))
+
+(defrec bignum-*
+  (fun (b1 b2)
+       (if (list-empty? b1)
+           list-empty
+           (bignum-+ (bignum-scale b2 (list-head b1))
+                     (bignum-scale (bignum-* (list-tail b1) b2) %base)))))
+
+(def bignum-zero? list-empty?)
+
+(defrec bignum-fact
+  (fun (n)
+       (if (= 0 n)
+           (int->bignum 1)
+           (bignum-* (int->bignum n) (bignum-fact (- n 1))))))
+
+(string-print "Factorial of? ")
+(let ((n (int-read)))
+  (int-print n)
+  (string-print "! = ")
+  (bignum-print (bignum-fact n))
+  (newline-print))

cs420-acc/l3-compiler/examples/bignums.l3m

@@ -0,0 +1,2 @@
+../library/lib.l3m
+bignums.l3

cs420-acc/l3-compiler/examples/calculator.l3

@@ -0,0 +1,105 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Expression evaluator program.
+
+(def space-print (fun () (char-print ' ')))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; List utilities
+
+;; Return first element of list [l].
+(def first
+  (fun (l) (list-head l)))
+;; Return second element of list [l].
+(def second
+  (fun (l)
+    (first (list-tail l))))
+;; Return third element of list [l].
+(def third
+  (fun (l)
+    (second (list-tail l))))
+
+;; Return the pair (key value) of the association-list [l] with key
+;; [k]. Produce an error if no such pair is found.
+(defrec assoc
+  (fun (k l)
+    (let ((h (list-head l)))
+      (if (= (list-head h) k)
+          h
+          (assoc k (list-tail l))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Handling of expressions. Expressions are specified by the following
+;; grammar:
+;; e ::=
+;;   (<op> <e> <e>)  where op in { + - * / }
+;; | (v . <character>)
+;; | (c . <number>)
+
+;; Test whether the argument is an operator.
+(def operator?
+  (fun (c)
+    (or (= c '+')
+        (= c '-')
+        (= c '*')
+        (= c '/'))))
+
+;; Print an expression (in Scheme-like format)
+(defrec print-expr
+  (fun (e)
+    (let ((tag (first e)))
+      (if (operator? tag)
+          (begin
+            (char-print '(')
+            (char-print tag)
+            (space-print)
+            (print-expr (second e))
+            (space-print)
+            (print-expr (third e))
+            (char-print ')'))
+          (if (= 'v' tag)
+              (char-print (list-tail e))
+              (int-print (list-tail e)))))))
+
+(def const (fun (c) (list-prepend 'c' c)))
+(def var (fun (v) (list-prepend 'v' v)))
+
+;; (+ x y)
+(def expr-1
+  (list-make '+' (var 'x') (var 'y')))
+
+;; (* x x)
+(def expr-2
+  (list-make '*' (var 'x') (var 'x')))
+
+;; (- (* x x) (+ x y))
+(def expr-3
+  (list-make '-' expr-2 expr-1))
+
+;; { x => 12, y => 20 }
+(def env-1
+  (list-make (list-prepend 'x' 12) (list-prepend 'y' 20)))
+
+(defrec eval
+  (fun (e env)
+    (let ((tag (first e)))
+      (if (operator? tag)
+          (let ((o1 (eval (second e) env))
+                (o2 (eval (third e) env)))
+            (if (= tag '+')
+                (+  o1 o2)
+                (if (= tag '-')
+                    (- o1 o2)
+                    (if (= tag '*') (* o1 o2) (/t o1 o2)))))
+          (if (= tag 'v')
+              (list-tail (assoc (list-tail e) env))
+              (list-tail e))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Main program
+
+(print-expr expr-3)
+(newline-print)
+(string-print "  => ")
+(int-print (eval expr-3 env-1))         ;Should print 112
+(newline-print)

cs420-acc/l3-compiler/examples/empty.l3

@@ -0,0 +1,10 @@
+(def id (fun (arg) arg))
+
+(def diff (fun (a b) (@/ a b)))
+
+(def a 6)
+
+(def tru (@= 1 1))
+(def fls (@= 0 1))
+
+(id (diff a 3))

cs420-acc/l3-compiler/examples/gcd.l3

@@ -0,0 +1,54 @@
+;; Basic arithmetic
+(def +@2 (fun (x y) (@+ x y)))
+(def +@3 (fun (x y z) (@+ x (@+ y z))))
+(def +@4 (fun (x y z t) (@+ (@+ x y) (@+ z t))))
+(def + +@2)
+
+(def -@1 (fun (x) (@- 0 x)))
+(def -@2 (fun (x y) (@- x y)))
+(def - -@2)
+
+
+;; Comparisons
+(def <@2 (fun (x y) (@< x y)))
+(def <@3 (fun (x y z) (and (@< x y) (@< y z))))
+(def < <@2)
+
+(def <=@2 (fun (x y) (@<= x y)))
+(def <=@3 (fun (x y z) (and (@<= x y) (@<= y z))))
+(def <= <=@2)
+
+(def >@2 (fun (x y) (@< y x)))
+(def >@3 (fun (x y z) (and (> x y) (> y z))))
+(def > >@2)
+
+(def >=@2 (fun (x y) (@<= y x)))
+(def >=@3 (fun (x y z) (and (>= x y) (>= y z))))
+(def >= >=@2)
+
+(def = (fun (x y) (@= x y)))
+(def != (fun (x y) (not (@= x y))))
+
+(def int-min (fun (x y) (if (<= x y) x y)))
+(def int-max (fun (x y) (if (>= x y) x y)))
+
+
+
+
+(def %t (fun (x y) (@% x y)))
+
+
+(def int-abs
+     (fun (i)
+          (if (< i 0) (- i) i)))
+
+
+(def int-gcd
+     (fun (x y)
+          (rec loop ((x (int-abs x))
+                     (y (int-abs y)))
+               (if (= 0 y)
+                   x
+                   (loop y (%t x y))))))
+
+(int-gcd 548 65)

cs420-acc/l3-compiler/examples/hello.l3

@@ -0,0 +1,19 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; "Hello, world" in L₃, the hard way (no syntactic sugar or library
+;; functions).
+
+(@byte-write 72)                        ;H
+(@byte-write 101)                       ;e
+(@byte-write 108)                       ;l
+(@byte-write 108)                       ;l
+(@byte-write 111)                       ;o
+(@byte-write 44)                        ;,
+(@byte-write 32)                        ;  (space)
+(@byte-write 119)                       ;w
+(@byte-write 111)                       ;o
+(@byte-write 114)                       ;r
+(@byte-write 108)                       ;l
+(@byte-write 100)                       ;d
+(@byte-write 33)                        ;!
+(@byte-write 10)                        ;  (newline)

cs420-acc/l3-compiler/examples/life.l3

@@ -0,0 +1,139 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Conway's game of life
+;; (https://en.wikipedia.org/wiki/Conway%27s_Game_of_Life)
+
+;; Notice that this program uses:
+;; - ANSI escape sequences, and so require a compatible terminal,
+;; - Unicode Block Elements [1], and so require a font supporting them.
+;;
+;; [1] https://unicode-table.com/en/blocks/block-elements/
+
+(def board-make@3
+     (fun (w h c)
+          (let ((b (@block-alloc-100 3)))
+            (@block-set! b 0 w)
+            (@block-set! b 1 h)
+            (@block-set! b 2 c)
+            b)))
+
+(def board-make@2
+     (fun (w h)
+          (board-make w h (vector-make (* w h) #f))))
+
+(def board-width
+     (fun (b) (@block-get b 0)))
+
+(def board-height
+     (fun (b) (@block-get b 1)))
+
+(def board-cells
+     (fun (b) (@block-get b 2)))
+
+(def board-cell-index
+     (fun (b x y)
+          (let ((x1 (%f x (board-width b)))
+                (y1 (%f y (board-height b))))
+            (+ x1 (* y1 (board-width b))))))
+
+(def board-get
+     (fun (b x y)
+          (vector-get (board-cells b) (board-cell-index b x y))))
+
+(def board-get/int
+     (fun (b x y)
+          (if (board-get b x y) 1 0)))
+
+(def board-set!
+     (fun (b x y v)
+          (vector-set! (board-cells b) (board-cell-index b x y) v)))
+
+(def live-neighbors-count
+     (let ((offsets (list-make (pair-make -1  -1)
+                               (pair-make -1   0)
+                               (pair-make -1   1)
+                               (pair-make  0  -1)
+                               (pair-make  0   1)
+                               (pair-make  1  -1)
+                               (pair-make  1   0)
+                               (pair-make  1   1))))
+       (fun (b x y)
+            (list-fold-left
+             (fun (c os)
+                  (+ c
+                     (board-get/int b (+ x (pair-fst os)) (+ y (pair-snd os)))))
+             0
+             offsets))))
+
+(def evolve-board
+     (fun (b)
+          (let ((b1 (board-make (board-width b) (board-height b))))
+            (rec loop ((x (- (board-width b) 1))
+                       (y (- (board-height b) 1)))
+                 (let* ((n (live-neighbors-count b x y))
+                        (s (or (= n 3) (and (= n 2) (board-get b x y)))))
+                   (board-set! b1 x y s)
+                   (cond ((> y 0) (loop x (- y 1)))
+                         ((> x 0) (loop (- x 1) (- (board-height b) 1)))
+                         (#t b1)))))))
+
+(def draw-board
+     (let ((code " ▗▖▄▝▐▞▟▘▚▌▙▀▜▛█"))
+       (fun (b)
+            (rec loop ((y 0) (x 0))
+                 (let* ((b0 (board-get/int b (+ x 1) (+ y 1)))
+                        (b1 (board-get/int b x (+ y 1)))
+                        (b2 (board-get/int b (+ x 1) y))
+                        (b3 (board-get/int b x y))
+                        (i (int-bitwise-or
+                            (int-shift-left b3 3)
+                            (int-shift-left b2 2)
+                            (int-shift-left b1 1)
+                            (int-shift-left b0 0))))
+                   (char-print (string-get code i))
+                   (cond ((< x (- (board-width b) 1))
+                          (loop y (+ x 2)))
+                         ((< y (- (board-height b) 1))
+                          (newline-print)
+                          (loop (+ y 2) 0))
+                         (#t
+                          (newline-print))))))))
+
+(defrec animate-life
+  (fun (b n)
+       (string-print "")     ;clear screen
+       (string-print "") ;set black background, white foreground
+       (string-print "[?25l")   ;hide cursor
+       (rec loop ((b b) (n n))
+            (string-print "")     ;move to top-left
+            (draw-board b)
+            (if (> n 0)
+                (loop (evolve-board b) (- n 1))))))
+
+(def b (board-make 158 68))
+(def glider-ul
+     (fun (b x y)
+          (board-set! b (+ x 1) (+ y 2) #t)
+          (board-set! b (+ x 2) (+ y 1) #t)
+          (board-set! b (+ x 0) (+ y 0) #t)
+          (board-set! b (+ x 1) (+ y 0) #t)
+          (board-set! b (+ x 2) (+ y 0) #t)))
+
+(def glider-dr
+     (fun (b x y)
+          (board-set! b (+ x 1) (+ y 0) #t)
+          (board-set! b (+ x 2) (+ y 1) #t)
+          (board-set! b (+ x 0) (+ y 2) #t)
+          (board-set! b (+ x 1) (+ y 2) #t)
+          (board-set! b (+ x 2) (+ y 2) #t)))
+
+(glider-dr b 4 4)
+(glider-dr b 10 5)
+(glider-ul b 13 15)
+(glider-ul b 5 20)
+(glider-ul b 17 22)
+(glider-ul b 23 5)
+(glider-ul b 2 7)
+(glider-ul b 19 33)
+
+(animate-life b 5000)

cs420-acc/l3-compiler/examples/life.l3m

@@ -0,0 +1,2 @@
+../library/lib.l3m
+life.l3

cs420-acc/l3-compiler/examples/maze.l3

@@ -0,0 +1,189 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+(defrec print-n-char
+  (fun (n c)
+       (if (> n 0)
+           (begin
+             (char-print c)
+             (print-n-char (- n 1) c)))))
+
+(defrec contains
+  (fun (l elem)
+       (and (not (list-empty? l))
+            (or (= (list-head l) elem)
+                (contains (list-tail l) elem)))))
+
+(defrec shuffle
+  (fun (l seed)
+       (let ((v (list->vector l)))
+         (vector-shuffle! v seed)
+         (vector->list v))))
+
+;; Cells
+
+(def cell
+     (fun (r c s)
+          (+ (* r s) c)))
+
+(def atE
+     (fun (c s)
+          (+ c 1)))
+
+(def atW
+     (fun (c s)
+          (- c 1)))
+
+(def atN
+     (fun (c s)
+          (- c s)))
+
+(def atS
+     (fun (c s)
+          (+ c s)))
+
+;; Walls
+;; Represented as a pair of 15-bits integers (cell indices), packed in
+;; a single one.
+
+(def wall-make
+     (fun (c1 c2)
+          (int-bitwise-or (int-shift-left c1 15) c2)))
+
+(def wall-cell-1
+     (fun (w)
+          (int-shift-right w 15)))
+
+(def wall-cell-2
+     (fun (w)
+          (int-bitwise-and w #x7FFF)))
+
+(def wall-up?
+     (fun (c1 c2 w)
+          (contains w (wall-make c1 c2))))
+
+
+;; Create a maze that has walls everywhere
+(defrec completeMaze-acc
+  (fun (r c s acc)
+       (if (< r s)
+           (if (< c s)
+               (let* ((rc (cell r c s))
+                      (res1 (if (< c (- s 1))
+                                (list-prepend (wall-make (cell r c s) (atE rc s)) acc)
+                                acc))
+                      (res2 (if (< r (- s 1))
+                                (list-prepend (wall-make (cell r c s) (atS rc s)) res1)
+                                res1)))
+                 (completeMaze-acc r (+ c 1) s res2))
+               (completeMaze-acc (+ r 1) 0 s acc))
+           acc)))
+
+(def completeMaze
+     (fun (s)
+          (completeMaze-acc 0 0 s list-empty)))
+
+;; Create a list of singleton lists for each cell of the maze
+(defrec fullyDisconnectedSets-acc
+  (fun (r c s acc)
+       (if (< r s)
+           (if (< c s)
+               (let ((res (list-prepend (list-make (cell r c s)) acc)))
+                 (fullyDisconnectedSets-acc r (+ c 1) s res))
+               (fullyDisconnectedSets-acc (+ r 1) 0 s acc))
+           acc)))
+
+(def fullyDisconnectedSets
+     (fun (s)
+          (fullyDisconnectedSets-acc 0 0 s list-empty)))
+
+(defrec connected
+  (fun (sets c1 c2)
+       (and (not (= sets list-empty))
+            (let ((set (list-head sets)))
+              (or (and (contains set c1)
+                       (contains set c2))
+                  (connected (list-tail sets) c1 c2))))))
+
+;; return the first element that satisfies p
+(def find
+     (fun (p l)
+          (let ((res (list-filter p l)))
+            (if (list-empty? res)
+                res
+                (list-head res)))))
+
+(def connect
+     (fun (sets c1 c2)
+          (let ((setOfC1 (find (fun (e) (contains e c1)) sets))
+                (setOfC2 (find (fun (e) (contains e c2)) sets)))
+            (list-prepend (list-append setOfC1 setOfC2)
+                          (list-filter (fun (e)
+                                            (and (not (contains e c1))
+                                                 (not (contains e c2))))
+                                       sets)))))
+
+;; execute body for each int between from and to
+(defrec for
+  (fun (from to body)
+       (if (< from to)
+           (begin
+             (body from)
+             (for (+ from 1) to body))
+           0)))
+
+(def print-maze
+     (fun (s w)
+          (let ((space ' ')
+                (wall 'X'))
+            (print-n-char (+ (* s 2) 1) wall)
+            (newline-print)
+            (for 0 s
+                 (fun (r)
+                      (char-print wall)
+                      (for 0 s
+                           (fun (c)
+                                (char-print space)
+                                (if (< c (- s 1))
+                                    (let ((rc (cell r c s)))
+                                      (char-print (if (wall-up? rc (atE rc s) w) wall space)))
+                                    0)))
+                      (char-print wall)
+                      (newline-print)
+                      (if (< r (- s 1))
+                          (begin
+                            (char-print wall)
+                            (for 0 s
+                                 (fun (c)
+                                      (let ((rc (cell r c s)))
+                                        (char-print (if (wall-up? rc (atS rc s) w) wall space))
+                                        (if (< c (- s 1))
+                                            (char-print wall)
+                                            0))))
+                            (char-print wall)
+                            (newline-print))
+                          0)))
+            (print-n-char (+ (* s 2) 1) wall)
+            (newline-print))))
+
+(defrec random-maze-acc
+  (fun (m c acc)
+       (if (list-empty? m)
+           acc
+           (let ((w (list-head m)))
+             (if (connected c (wall-cell-1 w) (wall-cell-2 w))
+                 (random-maze-acc (list-tail m) c (list-prepend w acc))
+                 (random-maze-acc (list-tail m) (connect c (wall-cell-1 w) (wall-cell-2 w)) acc))))))
+
+
+(def random-maze
+     (fun (s seed)
+          (let ((m (shuffle (completeMaze s) seed))
+                (c (fullyDisconnectedSets s)))
+            (random-maze-acc m c list-empty))))
+
+
+(string-print "Size: ") ; T
+(let ((size (int-read)))
+  (string-print "Seed: ") ; G
+  (let ((seed (int-read)))
+    (print-maze size (random-maze size seed))))

cs420-acc/l3-compiler/examples/maze.l3m

@@ -0,0 +1,2 @@
+../library/lib.l3m
+maze.l3

cs420-acc/l3-compiler/examples/pascal.l3

@@ -0,0 +1,53 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; Pascal's triangle
+
+(defrec zip
+  (fun (l1 l2)
+       (if (list-empty? l1)
+           list-empty
+           (list-prepend
+            (list-prepend (list-head l1) (list-head l2))
+            (zip (list-tail l1) (list-tail l2))))))
+
+(defrec %pascal
+  (fun (n)
+       (if (= n 1)
+           (list-make (list-make 1))
+           (let* ((p (%pascal (- n 1)))
+                  (p1 (zip (list-head p) (list-prepend 0 (list-head p))))
+                  (p2 (list-map (fun (pair)
+                                     (+ (list-head pair) (list-tail pair)))
+                                p1)))
+             (list-prepend (list-append p2 (list-make 1)) p)))))
+
+(def pascal (fun (n) (list-reverse (%pascal n))))
+
+(def list-int-print
+     (fun (l)
+          (char-print '(')
+                      (list-for-each (fun (elem)
+                                          (int-print elem)
+                                          (char-print ' '))
+                                     l)
+                      (char-print ')')))
+
+(def print-pascal
+     (fun (p)
+          (list-map
+           (fun (l)
+                (list-int-print l)
+                (newline-print))
+           p)))
+
+(defrec tui
+  (fun ()
+       (string-print "enter size (0 to exit)> ")
+       (let ((size (int-read)))
+         (if (= size 0)
+             0
+             (begin
+               (print-pascal (pascal size))
+               (tui))))))
+
+(tui)

cs420-acc/l3-compiler/examples/pow.l3

@@ -0,0 +1,4 @@
+;; In Emacs, open this file in -*- Scheme -*- mode
+
+(int-print (int-pow 3 12)) ; should print 531441
+(newline-print)

cs420-acc/l3-compiler/examples/printint.l3

@@ -0,0 +1,5 @@
+(string-print "Enter a number: ")
+(let ((n (int-read)))
+  (string-print "You entered ")
+  (int-print n)
+  (newline-print))

cs420-acc/l3-compiler/examples/printint.l3m

@@ -0,0 +1,2 @@
+../library/lib.l3m
+printint.l3

cs420-acc/l3-compiler/examples/queens.l3

@@ -0,0 +1,166 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; solutions are represented as integer list, where the index denotes the
+;; row (from the bottom), the value the column. for example, the solution
+;; for n = 4
+;;   _ _ _ _
+;;  | |o| | |
+;;  | | | |o|
+;;  |o| | | |
+;;  | | |o| |
+;;
+;; is represented as (3, 1, 4, 2)
+
+;; SOME USEFUL LIST FUNCTIONS
+
+(def list-range
+     (fun (f t)
+          (list-tabulate (+ 1 (- t f)) (fun (i) (+ f i)))))
+
+(def list-zip-with-index
+     (fun (l)
+          (list-zip l (list-range 1 (list-length l)))))
+
+(def list-int-print
+     (fun (l)
+          (char-print '(')
+                      (list-for-each (fun (elem)
+                                          (int-print elem)
+                                          (char-print ' '))
+                                     l)
+                      (char-print ')')))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; CHECK IF NO TWO QUEENS IN A COLUMN
+
+;; essentially checks for duplicates
+(defrec col-ok
+  (fun (rows)
+       (or (list-empty? rows)
+           (and (list-every? (fun (x) (not (= (list-head rows) x)))
+                             (list-tail rows))
+                (col-ok (list-tail rows))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; CHECK IF NO TWO QUEENS IN A DIAGONAL
+
+;; depth denotes how many rows x and y are separated
+(def on-diag
+     (fun (x y depth)
+          (or (= (+ x depth) y)
+              (= (- x depth) y))))
+
+(defrec diag-ok
+  (fun (rows)
+       (or (list-empty? rows)
+           (and (list-every? (fun (pair)
+                                  (not (on-diag (list-head rows)
+                                                (pair-fst pair)
+                                                (pair-snd pair))))
+                             (list-zip-with-index (list-tail rows))) ;; index is the row distance from (list-head rows)
+                (diag-ok (list-tail rows))))))
+
+;;;;;;;;;;;;;;;;;;;;;
+;; CHECKING SOLUTIONS
+
+(def partial-ok
+     (fun (rows)
+          (and (col-ok rows)
+               (diag-ok rows))))
+
+;; not actually used in the algorithm below
+(def queens-ok
+     (fun (rows n)
+          (and (list-every? (fun (x) (<= x n)) rows) ; no elt. bigger than n
+               (= n (list-length rows))              ; n queens
+               (partial-ok rows))))                  ; no conflict
+
+;;;;;;;;;;;;;;;;;;;;;
+;; FINDING A SOLUTION
+
+(def queens
+     (letrec ((%advance
+               (fun (partial n)
+                    (if (< (list-head partial) n)
+                        (%queens (list-prepend (+ 1 (list-head partial))
+                                               (list-tail partial))
+                                 n) ;; try next value of (list-head partial)
+                        list-empty)))   ;; there's no solution for (list-tail partial)
+              (%queens
+               (fun (partial n)
+                    (if (partial-ok partial)
+                        (if (= (list-length partial) n)
+                            partial ;; partial solution with full length: we're done
+                            (let ((sol (%queens (list-prepend 1 partial) n)))
+                              (if (list-empty? sol)
+                                  (%advance partial n)
+                                  sol)))
+                        (%advance partial n)))))
+       (fun (n) (%queens (list-make 1) n))))
+
+;;;;;;;;;;;
+;; PRINTING
+
+(defrec for
+  (fun (from to body)
+       (if (< from to)
+           (begin
+             (body from)
+             (for (+ from 1) to body)))))
+
+(def %header
+     (fun (rows)
+          (newline-print)
+          (int-print (list-length rows))
+          (string-print "-queen(s)")
+          (newline-print)
+          (string-print "list: ")
+          (list-int-print (list-reverse rows))
+          (newline-print)
+          (for 0 (list-length rows)
+               (fun (x) (string-print " _")))
+          (newline-print)))
+
+(def %row
+     (fun (p n)
+          (for 0 n
+               (fun (x)
+                    (string-print "|")
+                    (string-print (if (= (+ x 1) p) "o" " "))))
+          (string-print "|")
+          (newline-print)))
+
+(defrec %print-rows
+  (fun (rows n)
+       (if (= (list-length rows) n)
+           (%header rows))
+       (if (list-empty? rows)
+           (newline-print)
+           (begin
+             (%row (list-head rows) n)
+             (%print-rows (list-tail rows) n)))))
+
+(def print-solution
+     (fun (rows)
+          (if (= (list-length rows) 0)
+              (begin
+                (string-print "no solution found!")
+                (newline-print))
+              (%print-rows (list-reverse rows) (list-length rows)))))
+
+;;;;;;;;;;;;;;;;;
+;; USER INTERFACE
+
+(defrec tui
+  (fun ()
+       (string-print "enter size (0 to exit)> ")
+       (let ((size (int-read)))
+         (if (not (= size 0))
+             (begin
+               (print-solution (queens size))
+               (tui))))))
+
+
+;; "main"
+(tui)
+

cs420-acc/l3-compiler/examples/queens.l3m

@@ -0,0 +1,2 @@
+../library/lib.l3m
+queens.l3

cs420-acc/l3-compiler/examples/sudoku.l3

@@ -0,0 +1,317 @@
+;; In Emacs, open this file in -*- Scheme -*- mode.
+
+;; brute force sudoku solver using backtracking
+
+
+;; some list functions
+
+(defrec flat-map
+  (fun (f l)
+    (if (list-empty? l)
+        l
+        (list-append (f (list-head l)) (flat-map f (list-tail l))))))
+
+(defrec index-of
+  (fun (p i l)
+    (if (list-empty? l)
+      -1
+      (if (p (list-head l))
+        i
+        (index-of p (+ i 1) (list-tail l))))))
+
+(defrec list-n
+  (fun (init n)
+       (list-tabulate n (fun (i) init))))
+
+(defrec list-get-value
+  (fun (list index)
+    (if (= 1 index)
+      (list-head list)
+      (list-get-value (list-tail list) (- index 1)))))
+
+(defrec list-set-value
+  (fun (list index value)
+    (if (= 1 index)
+      (list-prepend value (list-tail list))
+      (list-prepend
+        (list-head list)
+        (list-set-value (list-tail list) (- index 1) value)))))
+
+
+;; functions on tables
+
+
+(def create-table
+  (fun (n)
+    (let ((size (* n n)))
+      (list-n (list-n 0 size) size))))
+
+
+(defrec transpose
+  (fun (table)
+    (if (list-empty? (list-head table))
+      table
+      (list-prepend
+        (list-map (fun (row) (list-head row)) table)
+        (transpose (list-map (fun (row) (list-tail row)) table))))))
+
+
+(defrec table-get-value
+  (fun (table cell)
+    (if (= 1 (list-head cell))
+      (list-get-value (list-head table) (list-tail cell))
+      (table-get-value
+        (list-tail table)
+        (list-prepend (- (list-head cell) 1) (list-tail cell))))))
+
+
+(defrec table-set-value
+  (fun (table cell value)
+    (if (= 1 (list-head cell))      ;; current row?
+      (list-prepend
+        (list-set-value (list-head table) (list-tail cell) value)
+        (list-tail table))
+      (list-prepend
+        (list-head table)
+        (table-set-value
+          (list-tail table)
+          (list-prepend (- (list-head cell) 1) (list-tail cell))
+          value)))))
+
+
+(defrec table-init
+  (fun (table cells values)
+    (if (list-empty? cells)
+      table
+      (table-init
+        (table-set-value table (list-head cells) (list-head values))
+        (list-tail cells)
+        (list-tail values)))))
+
+
+(defrec table-get-row
+  (fun (table i)
+    (if (= 1 i)
+      (list-head table)
+      (table-get-row (list-tail table) (- i 1)))))
+
+(def table-get-col
+  (fun (table i)
+    (table-get-row (transpose table) i)))
+
+
+;;;;;;;;;;;;;;;
+;; VERIFICATION
+
+;; no duplicates in the list (except 0's)
+(defrec list-no-duplicates
+  (fun (list)
+    (if (list-empty? list)
+        #t
+        (and
+          (list-every?
+            (fun (x) (or (= x 0) (not (= (list-head list) x))))
+            (list-tail list))
+          (list-no-duplicates (list-tail list))))))
+
+;; check if no duplicates in rows
+(def rows-ok
+  (fun (table)
+    (list-every?
+      (fun (row) (list-no-duplicates row))
+      table)))
+
+;; check if no duplicates in columns
+(def cols-ok
+  (fun (table)
+    (rows-ok (transpose table))))
+
+
+;; blockrows contains the first n rows of a sudoku, e.g.
+;; +-----+-----+
+;; | 1 2 | 3 4 |
+;; | 3 4 | 1 2 |
+;; +-----+-----+
+(defrec %blockrows-ok
+  (fun (blockrows n)
+    (if (list-empty? (list-head blockrows))
+      #t
+      (and
+        (list-no-duplicates
+          (flat-map (fun (row) (list-take row n)) blockrows))
+        (%blockrows-ok (list-map (fun (row) (list-drop row n)) blockrows) n)))))
+
+
+;; check if no duplicates in blocks (n x n)
+(defrec blocks-ok
+  (fun (table n)
+    (if (= 0 (list-length table))
+      #t
+      (and
+        (%blockrows-ok (list-take table n) n)
+        (blocks-ok (list-drop table n) n)))))
+
+
+;; no duplicates (but incomplete solution, i.e. with zeros)
+(def partial-ok
+  (fun (table n)
+    (and (rows-ok table)
+         (cols-ok table)
+         (blocks-ok table n))))
+
+
+;; all numbers between 0 and n
+(def numbers-ok
+  (fun (table n)
+    (list-every?
+      (fun (num) (and (> num 0) (<= num (* n n))))
+      (flat-map (fun (row) row) table))))
+
+
+;; sudoku solved
+(def table-ok
+  (fun (table n)
+    (and (rows-ok table)
+         (cols-ok table)
+         (numbers-ok table n)
+         (blocks-ok table n))))
+
+
+
+;;;;;;;;;;;
+;; PRINTING
+
+(defrec for
+  (fun (from to body)
+    (if (< from to)
+        (begin
+          (body from)
+          (for (+ from 1) to body))
+        0)))
+
+
+(def %header
+  (fun (n)
+    (for 0 n
+      (fun (x)
+        (string-print "+")
+        (for 0 (+ (* n 2) 1)
+          (fun (x) (string-print "-")))))
+    (string-print "+")
+    (newline-print)))
+
+(def %row
+  (fun (row n)
+    (for 0 (* n n)
+      (fun (x)
+        (if (= 0 (%t x n))
+          (string-print "| ")
+          0)
+        (let ((v (list-head (list-drop row x))))
+          (if (= v 0)
+            (string-print " ")
+            (int-print v))
+          (string-print " "))))
+     (string-print "|")
+     (newline-print)))
+
+
+(def print-table
+  (fun (rows n)
+    (int-print n)
+    (string-print "-sudoku")
+    (newline-print)
+    (for 0 n
+      (fun (x)
+        (%header n)
+        (for 0 n
+          (fun (y)
+            (%row (list-head (list-drop rows (+ (* x n) y))) n)))))
+    (%header n)
+    (newline-print)))
+
+
+
+;;;;;;;;;;;;;;;;;;;;
+;; SOLVING ALGORITHM
+
+
+(def %next-zero-cell
+  (fun (table)
+    (let*
+      ( (rowi
+          (index-of
+            (fun (row) (list-any? (fun (x) (= 0 x)) row))
+            1
+            table))
+        (row (list-head (list-drop table (- rowi 1))))
+        (coli
+          (index-of
+            (fun (x) (= x 0))
+            1
+            row)))
+      (list-prepend rowi coli))))
+
+
+(def sudoku
+  (letrec
+      ((%advance (fun (table cell n)
+                      (let ((val (table-get-value table cell)))
+                        (if (< val (* n n))
+                            (%sudoku (table-set-value table cell (+ val 1)) cell n)
+                            list-empty))))
+       ;; find solutions by trying values on 'cell' of 'table'
+       (%sudoku (fun (table cell n)
+                     (if (and (> (table-get-value table cell) 0) (partial-ok table n))
+                         (if (numbers-ok table n)    ;; partial solution with all numbers > 0: we're done
+                             table
+                             (let ((sol (%sudoku table (%next-zero-cell table) n)))
+                               (if (list-empty? sol)
+                                   (%advance table cell n)
+                                   sol)))
+                         (%advance table cell n)))))
+    (fun (table n) (%sudoku table (%next-zero-cell table) n))))
+
+;;;;;;;;;;;;;;;
+;; SOME TESTING
+
+
+;; solution for
+(def table2
+  (list-make (list-make 1 2 3 4) (list-make 3 4 1 2) (list-make 2 1 4 3) (list-make 4 3 2 1)))
+
+;; sudoku from http://www.nzz.ch/magazin/unterhaltung/sudoku, 6.2.2009, schwer
+(def nzz
+  (table-init
+    (create-table 3)
+    (list-append (list-make (list-prepend 1 1) (list-prepend 1 2) (list-prepend 1 6) (list-prepend 1 7) (list-prepend 2 1) (list-prepend 2 2) (list-prepend 2 5) (list-prepend 2 6) (list-prepend 2 8))
+      (list-append (list-make (list-prepend 2 9) (list-prepend 3 2) (list-prepend 3 3) (list-prepend 3 6) (list-prepend 3 8) (list-prepend 4 5) (list-prepend 4 8) (list-prepend 5 6) (list-prepend 5 7))
+        (list-append (list-make (list-prepend 6 3) (list-prepend 6 5) (list-prepend 6 9) (list-prepend 7 3) (list-prepend 7 4) (list-prepend 7 6) (list-prepend 7 8) (list-prepend 8 1) (list-prepend 8 2))
+                (list-make (list-prepend 9 1) (list-prepend 9 6) (list-prepend 9 7)))))
+    (list-append (list-make 1 9 5 4 6 3 9 2 7)
+      (list-append (list-make 8 5 7 6 2 4 9 7 2)
+        (list-append (list-make 3 1 7 1 8 4 6 4 8)
+                (list-make 7 1 3))))))
+
+
+;; example sudoku (very hard to solve for brute force algorithm), from
+;; http://en.wikipedia.org/wiki/Algorithmics_of_sudoku#Solving_sudokus_by_a_brute-force_algorithm
+(def hard
+  (table-init
+    (create-table 3)
+    (list-append (list-make (list-prepend 2 6) (list-prepend 2 8) (list-prepend 2 9) (list-prepend 3 3) (list-prepend 3 5) (list-prepend 4 4) (list-prepend 4 6) (list-prepend 5 3) (list-prepend 5 7))
+            (list-make (list-prepend 6 2) (list-prepend 7 1) (list-prepend 7 8) (list-prepend 7 9) (list-prepend 8 3) (list-prepend 8 5) (list-prepend 9 5) (list-prepend 9 9)))
+    (list-append (list-make 3 8 5 1 2 5 7 4 1) (list-make 9 5 7 3 2 1 4 9))))
+
+
+;; empty 2-sudoku (quick)
+(print-table (sudoku (create-table 2) 2) 2)
+
+;; empty 3-sudoku (some seconds)
+(print-table (sudoku (create-table 3) 3) 3)
+
+;; nzz 3-sudoku (some seconds)
+(print-table (sudoku nzz 3) 3)
+
+;; very hard 3-sudoku (about an hour?)
+;; (print-table (sudoku hard 3) 3)

cs420-acc/l3-compiler/examples/sudoku.l3m

@@ -0,0 +1,2 @@
+../library/lib.l3m
+sudoku.l3

cs420-acc/l3-compiler/examples/unimaze.l3

@@ -0,0 +1,221 @@
+;; In Emacs, open this file in -*- Scheme -*- mode
+
+;; Build and display random maze, using Kruskal's spanning-tree algorithm.
+;; See https://en.wikipedia.org/wiki/Kruskal's_algorithm
+
+;; Uses Unicode's box-drawing characters for display.
+
+;; Cells
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Maze cells are identified by their row and column indices in the
+;; maze. Rows and columns are numbered from 0, the origin being the
+;; top-left cell, as illustrated below:
+;;
+;;   |-------+-------+-------+-----|
+;;   | (0,0) | (0,1) | (0,2) | ... |
+;;   |-------+-------+-------+-----|
+;;   | (1,0) | (1,1) | (1,2) | ... |
+;;   |-------+-------+-------+-----|
+;;   | ...   |       |       |     |
+;;
+;; The two indices are represented as 15-bits (unsigned) integers,
+;; packed in a single 30-bits integer. The row index is put in the
+;; high-order bits, the column index in the low-order bits.
+
+(def cell-make
+     (fun (r c)
+          (int-bitwise-or (int-shift-left r 15)
+                          c)))
+
+(def cell-row
+     (fun (i)
+          (int-shift-right i 15)))
+
+(def cell-column
+     (fun (i)
+          (int-bitwise-and i #x7FFF)))
+
+(def cell= =)
+(def cell< <)
+
+;; Return true iff the cell is an exterior cell (i.e. it is surrounded
+;; by less than eight neighboring cells).
+(def cell-exterior?
+     (fun (cell rows columns)
+          (let ((r (cell-row cell))
+                (c (cell-column cell)))
+            (or (= 0 r) (= (- rows 1) r)
+                (= 0 c) (= (- columns 1) c)))))
+
+(def cell-interior?
+     (fun (cell rows columns)
+          (not (cell-exterior? cell rows columns))))
+
+;; Walls
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Walls are represented by the two cells they separate. The two cells
+;; are stored in a pair, with the smaller one first, to ensure that
+;; each wall has a unique representation.
+
+(defrec wall-make
+  (fun (c1 c2)
+       ;; (require (cell-index-valid? c1))
+       ;; (require (cell-index-valid? c2))
+       (if (cell< c1 c2)
+           (pair-make c1 c2)
+           (wall-make c2 c1))))
+
+(def wall-cell-1 pair-fst)
+(def wall-cell-2 pair-snd)
+
+(def wall= (pair-derive= cell= cell=))
+(def wall< (pair-derive< cell< cell<))
+
+;; Maze
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def maze-make
+     (fun (rows columns walls)
+          (let ((m (vector-make 3)))
+            (vector-set! m 0 rows)
+            (vector-set! m 1 columns)
+            (vector-set! m 2 walls)
+            m)))
+
+(def maze-rows
+     (fun (maze) (vector-get maze 0)))
+
+(def maze-columns
+     (fun (maze) (vector-get maze 1)))
+
+(def maze-walls
+     (fun (maze) (vector-get maze 2)))
+
+;; Maze building
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Return the list of all walls for a maze with the given number of
+;; [rows] and [columns]. Notice that only walls separating two cells
+;; of the maze are returned (e.g. those on the outside, separating
+;; cells with the surroundings of the maze, are not returned as they
+;; cannot be represented).
+(def all-walls
+     (fun (rows columns)
+          (let ((last-row (- rows 1))
+                (last-column (- columns 1)))
+            (rec loop ((r 0) (c 0) (walls list-empty))
+                 (cond ((= r last-row)
+                        walls)
+                       ((= c last-column)
+                        (loop (+ r 1) 0 walls))
+                       (#t
+                        (let* ((cell (cell-make r c))
+                               (wall-E (wall-make cell (cell-make r (+ c 1))))
+                               (walls (list-prepend wall-E walls))
+                               (wall-S (wall-make cell (cell-make (+ r 1) c)))
+                               (walls (list-prepend wall-S walls)))
+                          (loop r (+ c 1) walls))))))))
+
+(def maze-build-random-connected
+     (fun (rows columns rng-seed)
+          (let* ((wall-interiority
+                  (fun (w)
+                       (let ((c1 (wall-cell-1 w))
+                             (c2 (wall-cell-2 w)))
+                         (+ (if (cell-interior? c1 rows columns) 1 0)
+                            (if (cell-interior? c2 rows columns) 1 0)))))
+                 (wall-interior? (fun (w) (= (wall-interiority w) 2)))
+                 (wall-exterior? (fun (w) (= (wall-interiority w) 0)))
+                 (icell-index (fun (cell)
+                                   (let ((r (cell-row cell))
+                                         (c (cell-column cell)))
+                                     (+ (* (- columns 2) (- r 1))
+                                        (- c 1)))))
+                 (icells-count (* (- rows 1) (- columns 1))))
+
+            (let* ((non-ext-walls (list-filter (fun (w)
+                                                    (not (wall-exterior? w)))
+                                               (all-walls rows columns)))
+                   (int/bnd-walls (list-partition wall-interior? non-ext-walls))
+                   (int-walls (list->vector (pair-fst int/bnd-walls))))
+              (vector-shuffle! int-walls rng-seed)
+              (let* ((icells-sets (vector-tabulate icells-count
+                                                   (fun (_) (diset-make))))
+                     (kept-walls
+                      (vector-fold-left
+                       (fun (ws w)
+                            (let* ((c1 (wall-cell-1 w))
+                                   (e1 (vector-get icells-sets
+                                                   (icell-index c1)))
+                                   (c2 (wall-cell-2 w))
+                                   (e2 (vector-get icells-sets
+                                                   (icell-index c2))))
+                              (if (diset-same? e1 e2)
+                                  (list-prepend w ws)
+                                  (begin
+                                    (diset-merge! e1 e2)
+                                    ws))))
+                       list-empty
+                       int-walls)))
+                (maze-make rows
+                           columns
+                           (list-append (pair-snd int/bnd-walls)
+                                        kept-walls)))))))
+
+
+;; Maze printing
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def char-for-walls
+     (let ((wall-chars " ╵╶└╷│┌├╴┘─┴┐┤┬┼"))
+       (fun (n e s w)
+            (string-get wall-chars
+                        (+ (if n #b0001 0)
+                           (if e #b0010 0)
+                           (if s #b0100 0)
+                           (if w #b1000 0))))))
+
+(def maze-print
+     (fun (maze)
+          (let ((last-row (- (maze-rows maze) 1))
+                (last-column (- (maze-columns maze) 1))
+                (has-wall?
+                 (let ((sorted-walls (begin
+                                       (let ((ws (list->vector
+                                                  (maze-walls maze))))
+                                         (vector-sort! ws wall<)
+                                         ws))))
+                   (fun (c1 c2)
+                        (let ((w (wall-make c1 c2)))
+                          (>= (vector-binary-search sorted-walls w wall<)
+                              0))))))
+            (rec loop ((r 0) (c 0))
+                 (cond ((= r last-row)
+                        #u)
+                       ((= c last-column)
+                        (newline-print)
+                        (loop (+ r 1) 0))
+                       (#t
+                        (let ((c-tl (cell-make r c))
+                              (c-tr (cell-make r (+ c 1)))
+                              (c-bl (cell-make (+ r 1) c))
+                              (c-br (cell-make (+ r 1) (+ c 1))))
+                          (let ((w-n (has-wall? c-tl c-tr))
+                                (w-e (has-wall? c-tr c-br))
+                                (w-s (has-wall? c-br c-bl))
+                                (w-w (has-wall? c-bl c-tl)))
+                            (char-print (char-for-walls w-n w-e w-s w-w))
+                            (loop r (+ c 1))))))))))
+
+(def int-read/prompt
+     (fun (prompt)
+          (string-print prompt)
+          (int-read)))
+
+(let* ((columns (int-read/prompt " Maze width: "))
+       (rows (int-read/prompt    "Maze height: "))
+       (seed (int-read/prompt    "Random seed: ")))
+  (maze-print
+   (maze-build-random-connected rows columns seed)))

cs420-acc/l3-compiler/examples/unimaze.l3m

@@ -0,0 +1,2 @@
+../library/lib.l3m
+unimaze.l3