;
; New URL: http://www.iki.fi/~kartturi/software/stacks.lsp
;
; Coded by Antti Karttunen once upon a time. FORTH-code also coded
; by the same person. Thrice-recursive reverse-function in lisp is
; quite old algorithm, I think.
; Algorithms and code presented here in various languages are,
; of course, PUBLIC DOMAIN.
;
;
; This is little demo program to demonstrate some algorithms for
; reversing order of the elements of the stack with the help of
; one additional stack. (Somewhat related to the Hanoi towers???)
; These were originally written for FORTH so names of the stack
; manipulating primitives correspond to those of FORTH.
; (SWAP, DROP, DUP, R>, >R, etc).
;
; (fill '(a b c d e)) Clears the screen and "fills" the "parameter"
; stack, so that element a goes to the top, and element e to the bottom.
;
; (LIFTDOWN) rotates the topmost element of the stack to the bottom,
; rest of stack one upward.
; (LIFTUP) rotates the bottommost element of the stack to the top,
; rest of stack one downward.
; (REV1) reverses the parameter stack using LIFTDOWN.
;
; (REV2) reverses the parameter stack using LIFTUP.
;
; (REV3) reverses the parameter stack using hairy algorithm
; developed from the notorious "thrice-recursive"
; formula first used in Lisp reverse -function. Takes much longer than REV1
; & REV2.
;
;
; Note! This program writes directly to CGA-videomemory in textmode
; (from B000:8000 onward), so you must have a compatible screen,
; or use something like SIMCGA with Hercules.
; Or code new plotchar function! (Using ANSI-codes for example, and
; making this much slower).
; Also cls -function uses ANSI-sequence to clear the screen, so
; check that your machine has ansi-emulation on.
; Note! Arguments for fill -function should be atoms or numbers with
; just one letter or digit in their names. For example:
; after you have loaded this file with (load 'stacks) to St. Vitus Lisp,
; type (fill '(1 2 3 4 5 6 7 8 9)) to fill the stack with nine elements.
; Turn them upside down with (REV1), (REV2) or (REV3).
; The last one takes much longer, but uses more interesting algorithm.
;
/* Here are LIFTDOWN, LIFTUP, REV1, REV2 and REV3 written in FORTH:
( Must check that these actually WORK in some Forth! )
: LIFTDOWN DEPTH 0= IF ELSE DEPTH 1 = IF ELSE SWAP >R RECURSE R> THEN THEN ;
: LIFTUP DEPTH 0= IF ELSE DEPTH 1 = IF ELSE >R RECURSE R> SWAP THEN THEN ;
: REV1 DEPTH 0= IF ELSE DEPTH 1 = IF ELSE >R RECURSE R> LIFTDOWN THEN THEN ;
: REV2 DEPTH 0= IF ELSE DEPTH 1 = IF ELSE LIFTUP >R RECURSE R> THEN THEN ;
: REV3
DEPTH 0= IF
ELSE DEPTH 1 = IF
ELSE DEPTH 2 = IF SWAP
ELSE >R RECURSE R> SWAP >R >R RECURSE R> RECURSE R>
THEN
THEN
THEN
;
*/
; Here is that notorious version of reverse-function which inspired me
; to write REV3 in FORTH:
(defun rewerse (lista)
(cond ((null (cdr lista)) lista)
(t (cons (car (rewerse (cdr lista)))
(rewerse (cons
(car lista)
(rewerse (cdr (rewerse (cdr lista))))))))))
; This function returns the count how many times rewerse is called when
; rewersing lista of length n. Sequence runs like this:
; (1 1 5 17 57 189 625 2065 6821 22529 74409 ...)
(defun rewerse-count (n)
(cond ((lessp n 2) 1)
(t (add1
(+ (* 3 (rewerse-count (sub1 n)))
(rewerse-count (- n 2))
)
)
)
)
)
; This returns the same result for REV3 (for n stack elements).
; (1 1 1 4 10 25 61 148 358 865 2089 5044 12178 29401 70981 ...)
(defun rev3-count (n)
(cond ((lessp n 3) 1)
(t (add1
(+ (* 2 (rev3-count (sub1 n)))
(rev3-count (- n 2))
)
)
)
)
)
(defun cls () (princ `\e`) (princ "[2J") ())
(setq PAR-STACK (new-clist 50))
(setq RET-STACK (new-clist 50))
(setq P -1) ; Parameter Stack Pointer
(setq R -1) ; Return Stack Pointer
(setq base 23)
(defun fill (lista)
(setq P -1)
(setq R -1)
(cls)
(mapc #'PUSH (reverse lista))
(length lista)
)
(defun PUSH (elem)
(setq P (add1 P))
(rplacx P PAR-STACK elem)
(plot-stack-elem elem P 'P))
(defun POP (&aux topmost)
(setq topmost (TOP))
(DROP)
topmost)
(defun TOP ()
(cxr P PAR-STACK))
(defun DROP ()
(plot-stack-elem () P 'P)
(setq P (sub1 P)))
; Asterisked ones use the "return stack" instead of the "parameter stack":
(defun *PUSH (elem)
(setq R (add1 R))
(rplacx R RET-STACK elem)
(plot-stack-elem elem R 'R))
(defun *POP (&aux topmost)
(setq topmost (*TOP))
(*DROP)
topmost)
(defun *TOP ()
(cxr R RET-STACK))
(defun *DROP ()
(plot-stack-elem () R 'R)
(setq R (sub1 R)))
(defun DUP () (PUSH (TOP)))
(defun SWAP (&aux veba hiba)
(setq veba (POP))
(setq hiba (POP))
(PUSH veba)
(PUSH hiba))
(defun >R ()
(*PUSH (POP)))
(defun R> ()
(PUSH (*POP)))
(defun DEPTH () (add1 P)) ; How many elements in the parameter stack?
; This is the device dependent code! Program your own if you don't
; have the notorious PC with CGA compatible screen:
(defun plotchar (char line column)
(@= *screen* char (+ (* line 160) (* column 2)))
())
(defun plot-stack-elem (elem n stack-id)
(plotchar (cond ((intp elem) (+ `0` elem))
((null elem) ` `)
((@ elem)))
(- base n)
(cond ((eq stack-id 'P) 32)
((eq stack-id 'R) 36)
(t 40))))
; Rotate the topmost stack element to the bottom.
; ("Lift" is going down.)
(defun LIFTDOWN ()
(cond ((lessp (DEPTH) 2)) ; Do nothing if just one element (or none).
(t
(SWAP) ; Swap the topmost to the second topmost.
(>R) ; Toss the second topmost to the return stack.
(LIFTDOWN) ; Recurse.
(R>) ; When returning, toss elems back from return stack.
)
)
)
; Opposite to previous one. Rotate the bottommost stack elem to the top.
; ("Lift" is coming up.)
(defun LIFTUP ()
(cond ((lessp (DEPTH) 2)) ; Do nothing if just one element (or none).
(t
(>R) ; Toss elements to the return stack.
(LIFTUP) ; recurse.
(R>) ; Restore from the ret stack
(SWAP) ; And swap with the elem we got from the bottom.
)
)
)
; Reverse the stack elements, using LIFTDOWN as auxiliary procedure.
(defun REV1 ()
(cond ((lessp (DEPTH) 2)) ; Do nothing if just one element (or none).
(t
(>R) ; Topmost to the return stack
(REV1) ; Reverse the remaining.
(R>) ; Return the original topmost,
(LIFTDOWN) ; And rotate it to bottom.
)
)
)
(defun REV2 ()
(cond ((lessp (DEPTH) 2)) ; Do nothing if just one element (or none).
(t
(LIFTUP) ; Get the bottommost to the top of the stack.
(>R) ; Toss it to return stack
(REV2) ; Reverse the remaining.
(R>) ; And return the original bottommost from the ret stack.
)
)
)
;(setq *COUNT* 0) ; This was for testing the correctness of rev3-count
(defun REV3 ()
; (setq *COUNT* (add1 *COUNT*))
(cond ((zerop (DEPTH))) ; Do nothing if no elements,
((eq (DEPTH) 1)) ; or just one.
((eq (DEPTH) 2) (SWAP)) ; If two, then just swap them.
(t ; Else
(>R) ; Toss top elem to return stack.
(REV3) ; Reverse the remaining.
(R>) ; Restore the original top elem from ret stack.
(SWAP) ; Swap them.
(>R) ; And put both to ret stack. Orig last one is now
(>R) ; on bottom of it, and orig top one as second.
(REV3) ; reverse to get orig seq. without first and last.
(R>) ; take the orig top one back.
(REV3) ; reverse to get orig sequence reversed without original
(R>) ; last elem, which is got here from return stack.
)
)
)
; In Japanese NEC PC98 compatibles the text screen is from the
; address A000:0000 onward. (On some another models it is in E000:0000 -)
; Make new *screen* variable (plotchar uses it) with fake function.
; C00 is the flag bit indicating that its type is a string.
(defun set-epson-mode () (not (setq *screen* (fake 0xAC00 0x0000))))