From 12a1f6ad48f2b924f71239effeb90afca75a090f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 18 Nov 2017 22:00:44 -0800 Subject: [PATCH] altos/lisp: Fix some scheme compat issues flush -> flush-output nth -> list-ref (oh, and add list-tail) add let* (same as let for now) write control chars in octal make hanoi example work Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 4 +- src/lisp/ao_lisp_builtin.txt | 2 +- src/lisp/ao_lisp_const.lisp | 16 ++- src/lisp/ao_lisp_string.c | 5 +- src/test/hanoi.lisp | 185 ++++++++++++++++++----------------- 5 files changed, 115 insertions(+), 97 deletions(-) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index ccd13d07..e5370f90 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -533,9 +533,9 @@ ao_lisp_do_string_to_list(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_flush(struct ao_lisp_cons *cons) +ao_lisp_do_flush_output(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) + if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0)) return AO_LISP_NIL; ao_lisp_os_flush(); return _ao_lisp_bool_true; diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 4c484337..c324ca67 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -31,7 +31,7 @@ f_lexpr less_equal <= f_lexpr greater_equal >= f_lambda list_to_string list->string f_lambda string_to_list string->list -f_lambda flush +f_lambda flush_output flush-output f_lambda delay f_lexpr led f_lambda save diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 191ef005..861a4fc8 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -60,10 +60,17 @@ (defun caddr (l) (car (cdr (cdr l)))) -(defun nth (list n) - (cond ((= n 0) (car list)) - ((nth (cdr list) (1- n))) - ) +(define list-tail (lambda (x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) + ) + ) + +(define list-ref (lambda (x k) + (car (list-tail x k)) + ) ) ; simple math operators @@ -264,6 +271,7 @@ (let ((x 1)) x) +(define let* let) ; boolean operators (define or (lexpr (l) diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index fff218df..1daa50ea 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -140,7 +140,10 @@ ao_lisp_string_write(ao_poly p) printf ("\\t"); break; default: - putchar(c); + if (c < ' ') + printf("\\%03o", c); + else + putchar(c); break; } } diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp index e2eb0fa0..e873c796 100644 --- a/src/test/hanoi.lisp +++ b/src/test/hanoi.lisp @@ -16,129 +16,133 @@ ; ANSI control sequences -(defun move-to (col row) - (patom "\033[" row ";" col "H") +(define move-to (lambda (col row) + (for-each display (list "\033[" row ";" col "H")) + ) ) -(defun clear () - (patom "\033[2J") +(define clear (lambda () + (display "\033[2J") + ) ) -(defun display-string (x y str) - (move-to x y) - (patom str) +(define display-string (lambda (x y str) + (move-to x y) + (display str) + ) ) ; Here's the pieces to display -(setq stack '(" * " " *** " " ***** " " ******* " " ********* " "***********")) +(define tower '(" * " " *** " " ***** " " ******* " " ********* " "***********")) - ; Here's all of the stacks of pieces + ; Here's all of the towers of pieces ; This is generated when the program is run -(setq stacks nil) +(define towers ()) - ; Display one stack, clearing any +(define 1- (lambda (x) (- x 1))) + ; Display one tower, clearing any ; space above it -(defun display-stack (x y clear stack) - (cond ((= 0 clear) - (cond (stack - (display-string x y (car stack)) - (display-stack x (1+ y) 0 (cdr stack)) - ) - ) - ) - (t - (display-string x y " ") - (display-stack x (1+ y) (1- clear) stack) - ) - ) +(define display-tower (lambda (x y clear tower) + (cond ((= 0 clear) + (cond ((not (null? tower)) + (display-string x y (car tower)) + (display-tower x (1+ y) 0 (cdr tower)) + ) + ) + ) + (else + (display-string x y " ") + (display-tower x (1+ y) (1- clear) tower) + ) + ) + ) ) - ; Position of the top of the stack on the screen - ; Shorter stacks start further down the screen + ; Position of the top of the tower on the screen + ; Shorter towers start further down the screen -(defun stack-pos (y stack) - (- y (length stack)) +(define tower-pos (lambda (y tower) + (- y (length tower)) + ) ) - ; Display all of the stacks, spaced 20 columns apart + ; Display all of the towers, spaced 20 columns apart -(defun display-stacks (x y stacks) - (cond (stacks - (display-stack x 0 (stack-pos y (car stacks)) (car stacks)) - (display-stacks (+ x 20) y (cdr stacks))) - ) +(define display-towers (lambda (x y towers) + (cond ((not (null? towers)) + (display-tower x 0 (tower-pos y (car towers)) (car towers)) + (display-towers (+ x 20) y (cdr towers))) + ) + ) ) - ; Display all of the stacks, then move the cursor +(define top 0) + ; Display all of the towers, then move the cursor ; out of the way and flush the output -(defun display () - (display-stacks 0 top stacks) - (move-to 1 21) - (flush) +(define display-hanoi (lambda () + (display-towers 0 top towers) + (move-to 1 21) + (flush-output) + ) ) - ; Reset stacks to the starting state, with - ; all of the pieces in the first stack and the + ; Reset towers to the starting state, with + ; all of the pieces in the first tower and the ; other two empty -(defun reset-stacks () - (setq stacks (list stack nil nil)) - (setq top (+ (length stack) 3)) - (length stack) - ) - - ; more functions which could usefully - ; be in the rom image - -(defun min (a b) - (cond ((< a b) a) - (b) - ) +(define reset-towers (lambda () + (set! towers (list tower () ())) + (set! top (+ (length tower) 3)) + (length tower) + ) ) - ; Replace a stack in the list of stacks + ; Replace a tower in the list of towers ; with a new value -(defun replace (list pos member) - (cond ((= pos 0) (cons member (cdr list))) - ((cons (car list) (replace (cdr list) (1- pos) member))) - ) +(define replace (lambda (list pos member) + (cond ((= pos 0) (cons member (cdr list))) + ((cons (car list) (replace (cdr list) (1- pos) member))) + ) + ) ) - ; Move a piece from the top of one stack + ; Move a piece from the top of one tower ; to the top of another -(setq move-delay 100) - -(defun move-piece (from to) - (let ((from-stack (nth stacks from)) - (to-stack (nth stacks to)) - (piece (car from-stack))) - (setq from-stack (cdr from-stack)) - (setq to-stack (cons piece to-stack)) - (setq stacks (replace stacks from from-stack)) - (setq stacks (replace stacks to to-stack)) - (display) - (delay move-delay) - ) +(define move-delay 10) + +(define move-piece (lambda (from to) + (let* ((from-tower (list-ref towers from)) + (to-tower (list-ref towers to)) + (piece (car from-tower))) + (set! from-tower (cdr from-tower)) + (set! to-tower (cons piece to-tower)) + (set! towers (replace towers from from-tower)) + (set! towers (replace towers to to-tower)) + (display-hanoi) +; (delay move-delay) + ) + ) ) ; The implementation of the game -(defun _hanoi (n from to use) - (cond ((= 1 n) - (move-piece from to) - ) - (t - (_hanoi (1- n) from use to) - (_hanoi 1 from to use) - (_hanoi (1- n) use to from) - ) - ) +(define _hanoi (lambda (n from to use) + (cond ((= 1 n) + (move-piece from to) + ) + (else + (_hanoi (1- n) from use to) + (_hanoi 1 from to use) + (_hanoi (1- n) use to from) + ) + ) + ) ) ; A pretty interface which @@ -146,10 +150,13 @@ ; clears the screen and runs ; the program -(defun hanoi () - (setq len (reset-stacks)) - (clear) - (_hanoi len 0 1 2) - (move-to 0 23) - t +(define hanoi (lambda () + (let ((len)) + (set! len (reset-towers)) + (clear) + (_hanoi len 0 1 2) + (move-to 0 23) + #t + ) + ) ) -- 2.30.2