summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/lisp/ao_lisp_builtin.c4
-rw-r--r--src/lisp/ao_lisp_builtin.txt2
-rw-r--r--src/lisp/ao_lisp_const.lisp16
-rw-r--r--src/lisp/ao_lisp_string.c5
-rw-r--r--src/test/hanoi.lisp185
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
+ )
+ )
)
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 10:31:46 +0000