Microsoft muLISP-86 v5.10
This commit is contained in:
davidly
parent
27288dc13f
commit
d60ef9b732
207
Microsoft muLISP-86 v51/ANIMAL.LSP
Normal file
207
Microsoft muLISP-86 v51/ANIMAL.LSP
Normal file
@ -0,0 +1,207 @@
|
||||
;File: ANIMAL.LSP (C) 12/29/85 Soft Warehouse, Inc.
|
||||
|
||||
|
||||
(LOOP (PRIN1 '*) (EVAL (READ)) ((NULL RDS)) )
|
||||
|
||||
|
||||
(DEFUN ANIMAL (
|
||||
*BASE* *NAME* *DIRTY* )
|
||||
(CLEAR-SCREEN)
|
||||
(TERPRI 2)
|
||||
(CENTER "* * * T H E A N I M A L G A M E * * *")
|
||||
(TERPRI 3)
|
||||
(PRINTC "Hello, I would like to play the animal guessing game with you.")
|
||||
(TERPRI)
|
||||
(PRINTC "Please type in your first name and press the RETURN key so we")
|
||||
(PRINC "can chat on a more friendly basis: ")
|
||||
(CLEAR-INPUT)
|
||||
(SETQ *NAME* (STRING-CAPITALIZE (READ-LINE)))
|
||||
(TERPRI)
|
||||
(PRINTC "Thanks " *NAME* ", now think of an animal and I will try to guess")
|
||||
(PRINTC "what it is by asking you some yes-or-no questions.")
|
||||
(TERPRI)
|
||||
(SETQ *BASE* *INIT-BASE*)
|
||||
( ((OR
|
||||
(AND (RDS (PACK* *NAME* '.MEM))
|
||||
(PRINTC "Would you like to refresh my memory about animals from")
|
||||
(Y-OR-N-P "our previous session?") )
|
||||
(AND (RDS 'ANIMAL.MEM)
|
||||
(PRINTC "Would you like to refresh my memory about animals from")
|
||||
(Y-OR-N-P "the pre-built animal data file?") ) )
|
||||
(SETQ *BASE* (MAKE-BASE (READ))) ) )
|
||||
(RDS)
|
||||
(LOOP
|
||||
(TERPRI)
|
||||
(PRINC "After you think of an animal, press any key to start the game. ")
|
||||
(READ-KEY)
|
||||
(TERPRI 2)
|
||||
(PLAY-ROUND *BASE*)
|
||||
((NOT (Y-OR-N-P "Would you like to play another round?")))
|
||||
(CLEAR-SCREEN) )
|
||||
(TERPRI)
|
||||
( ((NOT *DIRTY*))
|
||||
(PRINTC *NAME* ", do you want me to save all you have taught me")
|
||||
((Y-OR-N-P "so I will remember it next time we play Animal?")
|
||||
(WRS (PACK* *NAME* '.MEM))
|
||||
(PRT-BASE *BASE* 0)
|
||||
(TERPRI)
|
||||
(WRS)
|
||||
(SETQ *DIRTY*)
|
||||
(TERPRI) )
|
||||
(TERPRI) )
|
||||
(PRINTC "I hope you enjoyed playing the Animal Game " *NAME* ".")
|
||||
(PRINC "Let's get together again some time!")
|
||||
(TERPRI 2) )
|
||||
|
||||
|
||||
(DEFUN PLAY-ROUND (BASE
|
||||
ANIMAL ANSWERS NEW-BASE QUESTION)
|
||||
(LOOP
|
||||
((ATOM (CDR BASE))
|
||||
((Y-OR-N-P (PACK* "I bet it's " (@ (CAR BASE)) "?"))
|
||||
(PRINTC "Yea, I got it! Thanks for the game " *NAME* ".")
|
||||
(TERPRI) )
|
||||
(PRINC "I give up, what animal were you thinking of? ")
|
||||
(SETQ ANIMAL (STRING-UPCASE (READ-LINE)))
|
||||
(TERPRI)
|
||||
((EQ ANIMAL (CAR BASE))
|
||||
(PRINTC "Stop fooling around " *NAME* ", that is what I just guessed!")
|
||||
(TERPRI) )
|
||||
(SETQ NEW-BASE (ALREADY-EXISTS ANIMAL (REVERSE ANSWERS) *BASE*))
|
||||
( ((NOT NEW-BASE))
|
||||
(PRINTC "I think you may have incorrectly answered the question")
|
||||
(TERPRI)
|
||||
(SPACES 10)
|
||||
(PRINTC """" (CAR NEW-BASE) "?""")
|
||||
(TERPRI)
|
||||
((Y-OR-N-P (PACK* *NAME*
|
||||
" are you sure you answered this question correctly?"))
|
||||
(REMOVE-ANIMAL ANIMAL *BASE*)
|
||||
(PRINTC "OK, I fixed by memory so I won't make that mistake again.")
|
||||
(TERPRI) )
|
||||
(TERPRI)
|
||||
(RETURN) )
|
||||
(PRINTC "What question can I ask for which a YES answer indicates")
|
||||
(PRINTC (@ ANIMAL) " rather than " (@ (CAR BASE)) "?")
|
||||
(SETQ QUESTION (STRING-RIGHT-TRIM "?.! " (READ-LINE)))
|
||||
(TERPRI)
|
||||
(DISPLACE BASE (LIST QUESTION (LIST (CAR BASE)) (LIST ANIMAL)))
|
||||
(PRINTC "Thanks for telling me that. I'll be sure to remember it.")
|
||||
(SETQ *DIRTY* T) )
|
||||
(PUSH (Y-OR-N-P (PACK* (CAR BASE) "?")) ANSWERS)
|
||||
(TERPRI)
|
||||
( ((CAR ANSWERS)
|
||||
(SETQ BASE (CADDR BASE)) )
|
||||
(SETQ BASE (CADR BASE)) ) ) )
|
||||
|
||||
(DEFUN ALREADY-EXISTS (ANIMAL ANSWERS BASE)
|
||||
((ATOM (CDR BASE)) NIL)
|
||||
((CAR ANSWERS)
|
||||
((MEMBER-BASE ANIMAL (CADR BASE)) BASE)
|
||||
(ALREADY-EXISTS ANIMAL (CDR ANSWERS) (CADDR BASE)) )
|
||||
((MEMBER-BASE ANIMAL (CADDR BASE)) BASE)
|
||||
(ALREADY-EXISTS ANIMAL (CDR ANSWERS) (CADR BASE)) )
|
||||
|
||||
(DEFUN REMOVE-ANIMAL (ANIMAL BASE)
|
||||
((MEMBER-BASE ANIMAL (CADR BASE))
|
||||
(SETQ SUB-BASE (CADR BASE))
|
||||
((EQ ANIMAL (CAR (CADR SUB-BASE)))
|
||||
(RPLACA (CDR BASE) (CADDR SUB-BASE)) )
|
||||
((EQ ANIMAL (CAR (CADDR SUB-BASE)))
|
||||
(RPLACA (CDR BASE) (CADR SUB-BASE)) )
|
||||
(REMOVE-ANIMAL ANIMAL (CADR BASE)) )
|
||||
(SETQ SUB-BASE (CADDR BASE))
|
||||
((EQ ANIMAL (CAR (CADR SUB-BASE)))
|
||||
(RPLACA (CDDR BASE) (CADDR SUB-BASE)) )
|
||||
((EQ ANIMAL (CAR (CADDR SUB-BASE)))
|
||||
(RPLACA (CDDR BASE) (CADR SUB-BASE)) )
|
||||
(REMOVE-ANIMAL ANIMAL (CADDR BASE)) )
|
||||
|
||||
(DEFUN MEMBER-BASE (ANIMAL BASE)
|
||||
(LOOP
|
||||
((ATOM (CDR BASE))
|
||||
(EQ (CAR BASE) ANIMAL) )
|
||||
((MEMBER-BASE ANIMAL (CADR BASE)))
|
||||
(SETQ BASE (CADDR BASE)) ) )
|
||||
|
||||
(DEFUN MAKE-BASE (BASE)
|
||||
((ATOM BASE)
|
||||
(LIST BASE) )
|
||||
(LIST (CAR BASE) (MAKE-BASE (CADR BASE)) (MAKE-BASE (CADDR BASE))) )
|
||||
|
||||
(DEFUN PRT-BASE (BASE TAB PRIN1)
|
||||
(SPACES TAB)
|
||||
((ATOM (CDR BASE))
|
||||
(PRIN1 (CAR BASE)) )
|
||||
(PRINC '"(")
|
||||
(PRINT (CAR BASE))
|
||||
(PRT-BASE (CADR BASE) (+ TAB 2))
|
||||
(TERPRI)
|
||||
(PRT-BASE (CADDR BASE) (+ TAB 2))
|
||||
(PRINC '")") )
|
||||
|
||||
(SETQ *INIT-BASE*
|
||||
'("Does it hava a backbone"
|
||||
("Can it fly"
|
||||
(WORM)
|
||||
(MOSQUITO))
|
||||
("Is it a warm blooded animal"
|
||||
("Does it have gills and live all its life in water"
|
||||
("Does it start life with gills and then become an air breather"
|
||||
("Does it have legs"
|
||||
(SNAKE)
|
||||
(CROCODILE))
|
||||
(FROG))
|
||||
("TUNA FISH"))
|
||||
("Does it nurse its young with milk"
|
||||
("Can it fly"
|
||||
(CHICKEN)
|
||||
(ROBIN))
|
||||
("Does it live in water"
|
||||
("Is it a commonly domesticated animal"
|
||||
(TIGER)
|
||||
(DOG))
|
||||
(DOLPHIN)) ))) )
|
||||
|
||||
|
||||
(DEFUN DISPLACE (LST1 LST2)
|
||||
(RPLACA LST1 (CAR LST2))
|
||||
(RPLACD LST1 (CDR LST2)) )
|
||||
|
||||
(DEFUN @ (NOUN)
|
||||
((FINDSTRING (CHAR NOUN 0) "AEIOUaeiou")
|
||||
(PACK* "an " NOUN) )
|
||||
(PACK* "a " NOUN) )
|
||||
|
||||
(DEFUN Y-OR-N-P (MSG
|
||||
CHAR READ-CHAR RDS WRS )
|
||||
( ((NULL MSG))
|
||||
(FRESH-LINE)
|
||||
(WRITE-STRING (PACK* MSG " (Y/N) ")) )
|
||||
(CLEAR-INPUT)
|
||||
(LOOP
|
||||
(SETQ CHAR (CHAR-UPCASE (READ-CHAR)))
|
||||
((EQ CHAR 'Y)
|
||||
(WRITE-LINE CHAR)
|
||||
T )
|
||||
((EQ CHAR 'N)
|
||||
(WRITE-LINE CHAR)
|
||||
NIL )
|
||||
(WRITE-BYTE 7) ) )
|
||||
|
||||
(DEFUN READ-KEY (
|
||||
READ-CHAR RDS)
|
||||
(READ-CHAR) )
|
||||
|
||||
(DEFUN PRINTC LST
|
||||
(PRINC (PACK LST))
|
||||
(TERPRI)
|
||||
'T )
|
||||
|
||||
(DEFUN CENTER (MSG)
|
||||
(SET-CURSOR (ROW)
|
||||
(TRUNCATE (- (CADDDR (MAKE-WINDOW)) (LENGTH MSG)) 2))
|
||||
(WRITE-LINE MSG) )
|
||||
|
||||
(ANIMAL (RDS))
|
||||
|
||||
205
Microsoft muLISP-86 v51/ANIMAL.MEM
Normal file
205
Microsoft muLISP-86 v51/ANIMAL.MEM
Normal file
@ -0,0 +1,205 @@
|
||||
;File: ANIMAL.MEM 08/27/85 Animal game data base
|
||||
|
||||
|
||||
("Does it nurse its young with milk"
|
||||
("Does it have legs"
|
||||
("Does it have a shell"
|
||||
("Does it have suckers on its arms"
|
||||
("Is it boneless"
|
||||
("Does it swim"
|
||||
SNAKE
|
||||
("Is it a ferocious meat eating fish"
|
||||
("Is it a type of salmon"
|
||||
("Can you wear it on your leg"
|
||||
GUPPY
|
||||
"GARTER SNAKE")
|
||||
CHINOOK)
|
||||
PIRANHA) )
|
||||
"SEA CUCUMBER")
|
||||
OCTOPUS)
|
||||
("Does it live in water"
|
||||
SNAIL
|
||||
CLAM) )
|
||||
("Does it have a beak"
|
||||
("Is it soft and squishy"
|
||||
("Does it go through metamorphosis"
|
||||
("Does it breathe fire"
|
||||
("Does it live in a colony"
|
||||
("Does it have claws"
|
||||
("Does it suck blood"
|
||||
("Is it an insect"
|
||||
("Does it live in a cavern"
|
||||
("Does it have horns"
|
||||
GECKO
|
||||
RAM)
|
||||
WUMPUS)
|
||||
("Does it annoy housewives"
|
||||
("Does it fly"
|
||||
GRASSHOPPER
|
||||
BUTTERFLY)
|
||||
COCKROACH) )
|
||||
("Does a clock do it too"
|
||||
FLEA
|
||||
TIC) )
|
||||
("Does it walk sideways"
|
||||
LOBSTER
|
||||
CRAB) )
|
||||
ANT)
|
||||
DRAGON)
|
||||
("Does it live in a hive"
|
||||
("Is it an insect"
|
||||
FROG
|
||||
("Does it suck blood"
|
||||
("Does it live in a nest"
|
||||
FLY
|
||||
WASP)
|
||||
MOSQUITO) )
|
||||
BEE) )
|
||||
("Do ants farm them"
|
||||
("Is it a reptile"
|
||||
("Does it have eight legs"
|
||||
("Does it have wings"
|
||||
CATERPILLAR
|
||||
COCKROACH)
|
||||
SPIDER)
|
||||
("Does it eat mice"
|
||||
SKINK
|
||||
"MONITOR LIZARD") )
|
||||
APHID) )
|
||||
("Does the male have a pretty tail"
|
||||
("Does it fly"
|
||||
("Does it have eight arms"
|
||||
("Is it the largest flightless bird"
|
||||
MYNAH
|
||||
("Is it extinct"
|
||||
OSTRICH
|
||||
"DODO BIRD") )
|
||||
OCTOPUS)
|
||||
("Does it have webbed feet for swimming"
|
||||
("Is it a scavenger"
|
||||
("Does it coo"
|
||||
("Does it have long legs"
|
||||
KIWI
|
||||
HERON)
|
||||
DOVE)
|
||||
VULTURE)
|
||||
("Is it a large stately swimming bird with a curved neck"
|
||||
("Does it honk"
|
||||
DUCK
|
||||
GOOSE)
|
||||
SWAN) ) )
|
||||
("Does the male have a comb"
|
||||
("Does it sometimes talk"
|
||||
PEACOCK
|
||||
PARROT)
|
||||
CHICKEN) ) ) )
|
||||
("Does it have a long neck"
|
||||
("Does it live in trees"
|
||||
("Does it oink"
|
||||
("Is it wild"
|
||||
("Does it have claws"
|
||||
("Does it talk"
|
||||
COW
|
||||
HUMAN)
|
||||
("Does it bark"
|
||||
CAT
|
||||
DOG) )
|
||||
("Is it a member of the cat family"
|
||||
("Does it hibernate"
|
||||
("Would Lloyd Bridges be scared of it"
|
||||
("Does it have a trunk"
|
||||
("Does it have antlers"
|
||||
("Does it hop"
|
||||
("Does it have a bill"
|
||||
("Does it have stripes"
|
||||
("Does it abandon sinking ships"
|
||||
("Does it like cheese"
|
||||
("Do they sometimes walk off cliffs en masse"
|
||||
("Is it the largest of the apes"
|
||||
("Does the male have a face marked in blue and scarlet"
|
||||
("Is it a fabulous animal with a single long horn"
|
||||
("Does it have a mask"
|
||||
("Is one named RIKI TIKI TAVI"
|
||||
("Is it a weasel"
|
||||
("Does it live in the water"
|
||||
WOLF
|
||||
("Can it walk on land"
|
||||
WHALE
|
||||
HIPPO) )
|
||||
WEASEL)
|
||||
MONGOOSE)
|
||||
RACCOON)
|
||||
UNICORN)
|
||||
MANDRILL)
|
||||
GORILLA)
|
||||
LEMMING)
|
||||
MOUSE)
|
||||
RAT)
|
||||
ZEBRA)
|
||||
PLATYPUS)
|
||||
KANGAROO)
|
||||
("Is it a large handsome African antelope"
|
||||
MOOSE
|
||||
KUDU) )
|
||||
("Is it hairy and extinct"
|
||||
ELEPHANT
|
||||
"WOOLY MAMMOTH") )
|
||||
("Does it repel enemies with smell"
|
||||
("Does it breathe air"
|
||||
SHARK
|
||||
("Does it have an airhole on its head"
|
||||
("Can it be mistaken for a mermaid"
|
||||
("Does it live in the Himalayas"
|
||||
HIPPOPOTAMUS
|
||||
"ABOMINABLE SNOWMAN")
|
||||
MANATEE)
|
||||
PORPOISE) )
|
||||
SKUNK) )
|
||||
("Is it covered with spines"
|
||||
("Does it live underground and eat twice its weight every day"
|
||||
("Does it emerge from hibernation to see his shadow"
|
||||
BEAR
|
||||
GROUNDHOG)
|
||||
SHREW)
|
||||
PORCUPINE) )
|
||||
("Does it have spots"
|
||||
("Does it have stripes"
|
||||
("Do its ears have tufts"
|
||||
LION
|
||||
LYNX)
|
||||
TIGER)
|
||||
("Is it the fastest running animal"
|
||||
LEOPARD
|
||||
CHEETAH) ) ) )
|
||||
PIG)
|
||||
("Does it fly"
|
||||
("Does it have a long tail"
|
||||
("Is it a sluggish two or three toed animal that hangs upside down"
|
||||
KOALA
|
||||
SLOTH)
|
||||
("Is it related to the raccoon"
|
||||
("Does it feign death when caught"
|
||||
MONKEY
|
||||
OPOSSUM)
|
||||
("Did Davy Crockett make a hat from its hide"
|
||||
KINKAJOU
|
||||
RACCOON) ) )
|
||||
BAT) )
|
||||
("Does it have a pouch"
|
||||
("Do people ride it"
|
||||
("Does it have stripes"
|
||||
("Does it swim in the ocean"
|
||||
("Is it wooly and live in South America"
|
||||
GIRAFFE
|
||||
LLAMA)
|
||||
("Can it clap"
|
||||
WALRUS
|
||||
SEAL) )
|
||||
ZEBRA)
|
||||
("Does it have a hump or two"
|
||||
("Is it usually found in South America"
|
||||
HORSE
|
||||
LLAMA)
|
||||
CAMEL) )
|
||||
KANGAROO) ) )
|
||||
|
||||
912
Microsoft muLISP-86 v51/COMMON.LSP
Normal file
912
Microsoft muLISP-86 v51/COMMON.LSP
Normal file
@ -0,0 +1,912 @@
|
||||
; File: COMMON.LSP 12/29/85 Soft Warehouse, Inc.
|
||||
|
||||
|
||||
; COMMON LISP Library: This file defines the library functions
|
||||
; referred to in Chapter 5 of the muLISP-86 Reference Manual.
|
||||
|
||||
|
||||
; Section 5.1: Selector Functions
|
||||
|
||||
(MOVD 'LENGTH 'LIST-LENGTH)
|
||||
|
||||
|
||||
; Section 5.2: Constructor Functions
|
||||
|
||||
(MOVD 'REVERSE 'REVAPPEND)
|
||||
|
||||
(SETQ *GENSYM-PREFIX* "G")
|
||||
(SETQ *GENSYM-COUNT* 0)
|
||||
|
||||
(DEFUN GENSYM (ATM)
|
||||
; (GENSYM) returns the symbol whose print name consists of *GENSYM-PREFIX*
|
||||
; concatenated to *GENSYM-COUNT* and increments *GENSYM-COUNT*.
|
||||
; (GENSYM symbol) sets *GENSYM-PREFIX* to <symbol>.
|
||||
; (GENSYM integer) sets *GENSYM-COUNT* to <integer>.
|
||||
( ((NULL ATM))
|
||||
((SYMBOLP ATM)
|
||||
(SETQ *GENSYM-PREFIX* ATM) )
|
||||
((AND (INTEGERP ATM) (>= ATM 0))
|
||||
(SETQ *GENSYM-COUNT* ATM) ) )
|
||||
(PROG1 (PACK* *GENSYM-PREFIX* *GENSYM-COUNT*)
|
||||
(INCQ *GENSYM-COUNT*)) )
|
||||
|
||||
|
||||
; Section 5.3: Modifier Functions
|
||||
|
||||
(MOVD 'NREVERSE 'NRECONC)
|
||||
(MOVD 'SORT 'STABLE-SORT)
|
||||
|
||||
|
||||
; Section 5.4: Recognizer Functions
|
||||
|
||||
(MOVD 'SYMBOLP 'STRINGP)
|
||||
(MOVD 'NUMBERP 'RATIONALP)
|
||||
|
||||
|
||||
; Section 5.5: Comparator Functions
|
||||
|
||||
(MOVD 'EQUAL 'TREE-EQUAL)
|
||||
|
||||
|
||||
; Section 5.7: Assignment Functions
|
||||
|
||||
(DEFMACRO SETF LST
|
||||
((NULL LST) NIL)
|
||||
((NULL (CDDR LST))
|
||||
((ATOM (CAR LST))
|
||||
(CONS 'SETQ LST) )
|
||||
(MAKE-SET-FORM (CAR LST) (CADR LST)) )
|
||||
(CONS 'PROGN (SETF-AUX LST)) )
|
||||
|
||||
(DEFUN SETF-AUX (LST)
|
||||
((NULL LST) NIL)
|
||||
((ATOM (CAR LST))
|
||||
(CONS (LIST 'SETQ (CAR LST) (CADR LST)) (SETF-AUX (CDDR LST))) )
|
||||
(CONS (MAKE-SET-FORM (CAR LST) (CADR LST)) (SETF-AUX (CDDR LST))) )
|
||||
|
||||
(DEFUN MAKE-SET-FORM (PLACE VALUE)
|
||||
((EQ (CAR PLACE) 'CAR)
|
||||
(LIST 'CAR (LIST 'RPLACA (CADR PLACE) VALUE)) )
|
||||
((OR (EQ (CAR PLACE) 'CDR) (EQ (CAR PLACE) 'REST))
|
||||
(LIST 'CDR (LIST 'RPLACD (CADR PLACE) VALUE)) )
|
||||
((EQ (CAR PLACE) 'NTH)
|
||||
(LIST 'CAR (LIST 'RPLACA (CONS 'NTHCDR (CDR PLACE)) VALUE)) )
|
||||
((EQ (CAR PLACE) 'GET)
|
||||
(LIST 'PUT (CADR PLACE) (CADDR PLACE) VALUE) )
|
||||
((EQ (CAR PLACE) 'SYMBOL-FUNCTION)
|
||||
(LIST 'PUTD (CADR PLACE) VALUE) )
|
||||
((GET (CAR PLACE) 'CAR) (LIST 'CAR
|
||||
(LIST 'RPLACA (LIST (GET (CAR PLACE) 'CAR) (CADR PLACE)) VALUE)) )
|
||||
((GET (CAR PLACE) 'CDR) (LIST 'CDR
|
||||
(LIST 'RPLACD (LIST (GET (CAR PLACE) 'CDR) (CADR PLACE)) VALUE)) )
|
||||
((GET (CAR PLACE) 'NTH)
|
||||
(LIST 'CAR (LIST 'RPLACA
|
||||
(LIST 'NTHCDR (GET (CAR PLACE) 'NTH) (CADR PLACE))
|
||||
VALUE)) )
|
||||
((MACRO-FUNCTION-P (CAR PLACE))
|
||||
(MAKE-SET-FORM (MACROEXPAND PLACE) VALUE) )
|
||||
(BREAK (LIST 'SETF PLACE VALUE) "Invalid Place Form") )
|
||||
|
||||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'CAR (CDR PAIR)))
|
||||
'((CAAR . CAR) (CADR . CDR)
|
||||
(CAAAR . CAAR) (CAADR . CADR) (CADAR . CDAR) (CADDR . CDDR)
|
||||
(CAAAAR . CAAAR) (CAAADR . CAADR) (CAADAR . CADAR) (CAADDR . CADDR)
|
||||
(CADAAR . CDAAR) (CADADR . CDADR) (CADDAR . CDDAR) (CADDDR . CDDDR)) )
|
||||
|
||||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'CDR (CDR PAIR)))
|
||||
'((CDAR . CAR) (CDDR . CDR)
|
||||
(CDAAR . CAAR) (CDADR . CADR) (CDDAR . CDAR) (CDDDR . CDDR)
|
||||
(CDAAAR . CAAAR) (CDAADR . CAADR) (CDADAR . CADAR) (CDADDR . CADDR)
|
||||
(CDDAAR . CDAAR) (CDDADR . CDADR) (CDDDAR . CDDAR) (CDDDDR . CDDDR)) )
|
||||
|
||||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'NTH (CDR PAIR)))
|
||||
'((FIRST . 0) (SECOND . 1) (THIRD . 2) (FOURTH . 3) (FIFTH . 4)
|
||||
(SIXTH . 5) (SEVENTH . 6) (EIGHTH . 7) (NINTH . 8) (TENTH . 9)) )
|
||||
|
||||
(DEFMACRO PUSHNEW (OBJ SYM TEST)
|
||||
(LIST 'SETQ SYM (LIST 'ADJOIN OBJ SYM TEST)) )
|
||||
|
||||
|
||||
; Section 5.10: Definition Primitives
|
||||
|
||||
(MOVD 'REMD 'FMAKUNBOUND)
|
||||
|
||||
|
||||
; Section 5.11.1: Character Functions
|
||||
|
||||
(DEFUN DIGIT-CHAR-P (SYM N)
|
||||
((SYMBOLP SYM)
|
||||
( ((AND (INTEGERP N) (<= 2 N 36)))
|
||||
(SETQ N 10) )
|
||||
((NUMERIC-CHAR-P SYM)
|
||||
(SETQ SYM (- (ASCII SYM) 48))
|
||||
((< SYM N) SYM) )
|
||||
((UPPER-CASE-P SYM)
|
||||
(SETQ SYM (- (ASCII SYM) 55))
|
||||
((< SYM N) SYM) ) ) )
|
||||
|
||||
(DEFUN CHAR-CODE (SYM)
|
||||
((SYMBOLP SYM)
|
||||
(ASCII SYM) ) )
|
||||
|
||||
(DEFUN CODE-CHAR (N)
|
||||
((AND (INTEGERP N) (<= 0 N 255))
|
||||
(ASCII N) ) )
|
||||
|
||||
|
||||
; Section 5.11.2: String Functions
|
||||
|
||||
(DEFMACRO STRING-EQUAL (ATM1 ATM2)
|
||||
(LIST 'STRING= ATM1 ATM2 T) )
|
||||
|
||||
(DEFMACRO STRING-LESSP (ATM1 ATM2)
|
||||
(LIST 'STRING< ATM1 ATM2 T) )
|
||||
|
||||
(DEFMACRO STRING-GREATERP (ATM1 ATM2)
|
||||
(LIST 'STRING> ATM1 ATM2 T) )
|
||||
|
||||
(DEFMACRO STRING-NOT-GREATERP (ATM1 ATM2)
|
||||
(LIST 'STRING<= ATM1 ATM2 T) )
|
||||
|
||||
(DEFMACRO STRING-NOT-LESSP (ATM1 ATM2)
|
||||
(LIST 'STRING>= ATM1 ATM2 T) )
|
||||
|
||||
(DEFMACRO STRING-NOT-EQUAL (ATM1 ATM2)
|
||||
(LIST 'STRING/= ATM1 ATM2 T) )
|
||||
|
||||
|
||||
; Section 5.12: Arithmetic Functions
|
||||
|
||||
(DEFMACRO INCF (PLACE N)
|
||||
((NULL N)
|
||||
((ATOM PLACE)
|
||||
(LIST 'INCQ PLACE) )
|
||||
(MAKE-SET-FORM PLACE (LIST 'ADD1 PLACE)) )
|
||||
((ATOM PLACE)
|
||||
(LIST 'INCQ PLACE N) )
|
||||
(MAKE-SET-FORM PLACE (LIST '+ PLACE N)) )
|
||||
|
||||
(DEFMACRO DECF (PLACE N)
|
||||
((NULL N)
|
||||
((ATOM PLACE)
|
||||
(LIST 'DECQ PLACE) )
|
||||
(MAKE-SET-FORM PLACE (LIST 'SUB1 PLACE)) )
|
||||
((ATOM PLACE)
|
||||
(LIST 'DECQ PLACE N) )
|
||||
(MAKE-SET-FORM PLACE (LIST '- PLACE N)) )
|
||||
|
||||
|
||||
; Section 5.12.5: Irrational and Transcendental Functions
|
||||
|
||||
(DEFUN GET-CONSTANT (CONSTANT FORM)
|
||||
;GET-CONSTANT returns the value of numerical constant, accurate to the
|
||||
;current precision.
|
||||
((EQL (PRECISION) (GET CONSTANT 'PRECISION))
|
||||
(EVAL CONSTANT) )
|
||||
(SET CONSTANT
|
||||
(IF (AND (GET CONSTANT 'PRECISION)
|
||||
(< (PRECISION) (GET CONSTANT 'PRECISION)) )
|
||||
(/ (NUMERATOR (EVAL CONSTANT)) (DENOMINATOR (EVAL CONSTANT)))
|
||||
(EVAL FORM) ))
|
||||
(PUT CONSTANT 'PRECISION (PRECISION))
|
||||
(EVAL CONSTANT) )
|
||||
|
||||
|
||||
(DEFUN EXP (N)
|
||||
;(EXP n) returns e^n, accurate to the current precision.
|
||||
((NUMBERP N)
|
||||
((ZEROP N) 1)
|
||||
((PLUSP (PRECISION))
|
||||
((MINUSP N)
|
||||
(/ 1 (EXP (- N))) )
|
||||
((= N 1)
|
||||
(GET-CONSTANT 'E '(EXP-AUX 1)) )
|
||||
((> N 1)
|
||||
(LET ((Q (DIVIDE (NUMERATOR N) (DENOMINATOR N))))
|
||||
(* (EXPT-AUX (GET-CONSTANT 'E '(EXP-AUX 1)) (CAR Q))
|
||||
(EXP-AUX (/ (CDR Q) (DENOMINATOR N)))) ) )
|
||||
(EXP-AUX N) )
|
||||
(BREAK (LIST 'EXP N) "Infinite Precision") )
|
||||
(BREAK (LIST 'EXP N) "Nonnumeric Argument") )
|
||||
|
||||
(DEFUN EXP-AUX (N
|
||||
;If 0<n<=1, (EXP-AUX n) returns e^n, accurate to the current
|
||||
;precision, using the fact that EXP (p/q) =
|
||||
;((...(((q+p)2q+p^2)3q+p^3)4q+...+p^(m-1))mq + p^m) / (m! q^m),
|
||||
P Q M TERM NUMR DENR PRECISION BITLENGTH )
|
||||
(SETQ PRECISION (* 32 (PRECISION))
|
||||
M 1
|
||||
P (NUMERATOR N)
|
||||
Q (DENOMINATOR N)
|
||||
TERM P
|
||||
NUMR (+ P Q)
|
||||
DENR Q )
|
||||
(LOOP
|
||||
(INCQ M)
|
||||
(SETQ TERM (* P TERM)
|
||||
NUMR (+ TERM (* Q NUMR M))
|
||||
DENR (* Q DENR M)
|
||||
BITLENGTH (- PRECISION (INTEGER-LENGTH DENR)) )
|
||||
( ((MINUSP BITLENGTH)
|
||||
(SETQ TERM (SHIFT TERM BITLENGTH)
|
||||
DENR (SHIFT DENR BITLENGTH)
|
||||
NUMR (SHIFT NUMR BITLENGTH) ) ) )
|
||||
((ZEROP TERM)
|
||||
(/ NUMR DENR) ) ) )
|
||||
|
||||
(IF (PLUSP (PRECISION)) (EXP 1)) ;Initialize the variable E
|
||||
|
||||
|
||||
(DEFUN EXPT (N M)
|
||||
;(EXPT n m) returns n^m.
|
||||
((AND (NUMBERP N) (NUMBERP M))
|
||||
((ZEROP M) 1)
|
||||
((ZEROP N)
|
||||
((MINUSP M)
|
||||
(BREAK (LIST 'EXPT N M) "Zero Divide") )
|
||||
0 )
|
||||
((MINUSP M)
|
||||
(/ 1 (EXPT-AUX N (- M))) )
|
||||
(EXPT-AUX N M) )
|
||||
(BREAK (LIST 'EXPT N M) "Nonnumeric Argument") )
|
||||
|
||||
(DEFUN EXPT-AUX (N M
|
||||
;If m>0, (EXPT-AUX n m) returns n^m. If m is a ratio the result may
|
||||
;be only an approximation to n^m, accurate to the current precision.
|
||||
ANS )
|
||||
((= N 1) 1)
|
||||
((INTEGERP M)
|
||||
((= M 1) N)
|
||||
(SETQ ANS 1)
|
||||
(LOOP ;Binary power method
|
||||
( ((ODDP M)
|
||||
(SETQ ANS (* N ANS)) ) )
|
||||
((ZEROP (SETQ M (SHIFT M -1))) ANS)
|
||||
(SETQ N (* N N)) ) )
|
||||
((PLUSP (PRECISION))
|
||||
((MINUSP N)
|
||||
((ODDP (DENOMINATOR M))
|
||||
((EVENP (NUMERATOR M))
|
||||
(EXP (* M (LN-AUX (- N)))) )
|
||||
(- (EXP (* M (LN-AUX (- N))))) )
|
||||
(BREAK (LIST 'EXPT N M) "Invalid Argument") )
|
||||
(EXP (* M (LN-AUX N))) )
|
||||
(BREAK (LIST 'EXPT N M) "Infinite Precision") )
|
||||
|
||||
|
||||
(DEFUN LOG (N M)
|
||||
;(LOG n m) returns base m logarithm of n. m defaults to e, the base
|
||||
;of the natural logarithms.
|
||||
(SETQ N (LN N))
|
||||
((NULL M) N)
|
||||
((ZEROP M) 0)
|
||||
(/ N (LN M)) )
|
||||
|
||||
(DEFUN LN (N)
|
||||
;(LN n) returns ln n, the natural logarithm of n.
|
||||
((NUMBERP N)
|
||||
((PLUSP N)
|
||||
((= N 1) 0)
|
||||
((PLUSP (PRECISION))
|
||||
((= N 2)
|
||||
(GET-CONSTANT 'LN2 '(LN-AUX 2)) )
|
||||
(LN-AUX N) )
|
||||
(BREAK (LIST 'LN N) "Infinite Precision") )
|
||||
(BREAK (LIST 'LN N) "Invalid Argument") )
|
||||
(BREAK (LIST 'LN N) "Nonnumeric Argument") )
|
||||
|
||||
(DEFUN LN-AUX (N
|
||||
;If n>0, (LN-AUX n) returns ln n, accurate to the current precision,
|
||||
;using the fact that with p/q = (x-1)/(x+1) = u,
|
||||
;LN x = 2 (u + u^3/3 + u^5/5 + ... + u^m/m) =
|
||||
;(...(((6pq^2 + 2p^3)5q^2 + 2 3p^5)7q^2 + 2 3 5p^7)9q^2 +
|
||||
; ...+2 3 5 ...(m-2)p^m) / (3 5 ...m q^m),
|
||||
P Q PLEN QLEN SHIFT M TERM NUMR DENR PRECISION BITLENGTH )
|
||||
((= N 2)
|
||||
(SETQ PRECISION (* 32 (PRECISION))
|
||||
M 11
|
||||
TERM 945
|
||||
NUMR 638195436
|
||||
DENR 1841443065 )
|
||||
; LN 2 ~= (2/9) (1 + (1/9)/3 + (1/9)^2/5 + ... + (1/9)^m/(2m+1)) =
|
||||
; 2 (...(((9 3 + 1)9 5 + 3)9 7 + 3 5)9 9 + ... + 3 5 ...(2m-1))
|
||||
; / (3 5 ...(2m+1) 3^(2m+1)), with single-precision head start
|
||||
(LOOP
|
||||
(SETQ TERM (* M TERM)
|
||||
M (+ M 2)
|
||||
NUMR (+ TERM (* 9 M NUMR))
|
||||
DENR (* 9 M DENR)
|
||||
BITLENGTH (- PRECISION (INTEGER-LENGTH NUMR)) )
|
||||
( ((MINUSP BITLENGTH)
|
||||
(SETQ TERM (SHIFT TERM BITLENGTH)
|
||||
NUMR (SHIFT NUMR BITLENGTH)
|
||||
DENR (SHIFT DENR BITLENGTH) ) ) )
|
||||
((ZEROP TERM)
|
||||
(/ (SHIFT NUMR 1) DENR) ) ) )
|
||||
((< (NUMERATOR N) (DENOMINATOR N))
|
||||
(- (LN-AUX (/ 1 N))) )
|
||||
(SETQ PRECISION (* 32 (PRECISION))
|
||||
SHIFT 0
|
||||
P (NUMERATOR N)
|
||||
Q (DENOMINATOR N)
|
||||
PLEN (INTEGER-LENGTH P)
|
||||
QLEN (INTEGER-LENGTH Q) )
|
||||
( ((> PLEN QLEN) ;Make 3/4 < N <= 3/2:
|
||||
((> (SHIFT P 1) (* 3 Q))
|
||||
(SETQ SHIFT (- PLEN QLEN))
|
||||
((> PLEN PRECISION)
|
||||
(SETQ P (SHIFT P (- PRECISION PLEN))
|
||||
Q (SHIFT Q (- PRECISION QLEN)))
|
||||
((> (SHIFT P 1) (* 3 Q))
|
||||
(SETQ SHIFT (ADD1 SHIFT)
|
||||
N (/ P (SHIFT Q 1))) )
|
||||
((< (SHIFT P 2) (* 3 Q))
|
||||
(SETQ SHIFT (SUB1 SHIFT)
|
||||
N (/ P (SHIFT Q -1))) )
|
||||
(SETQ N (/ P Q)) )
|
||||
((> (SHIFT P 1) (* 3 (SETQ Q (SHIFT Q SHIFT))))
|
||||
(SETQ SHIFT (ADD1 SHIFT)
|
||||
N (/ P (SHIFT Q 1))) )
|
||||
((< (SHIFT P 2) (* 3 Q))
|
||||
(SETQ SHIFT (SUB1 SHIFT)
|
||||
N (/ P (SHIFT Q -1))) )
|
||||
(SETQ N (/ P Q)) ) )
|
||||
((> (SHIFT P 1) (* 3 Q))
|
||||
(SETQ SHIFT 1
|
||||
N (/ P (SHIFT Q 1))) ) )
|
||||
(SETQ N (/ (- (NUMERATOR N) (DENOMINATOR N))
|
||||
(+ (NUMERATOR N) (DENOMINATOR N)))
|
||||
PLEN (* N N)
|
||||
P (NUMERATOR PLEN)
|
||||
Q (DENOMINATOR PLEN)
|
||||
NUMR (SHIFT (NUMERATOR N) 1)
|
||||
TERM NUMR
|
||||
DENR (DENOMINATOR N)
|
||||
PRECISION (- PRECISION (INTEGER-LENGTH SHIFT))
|
||||
M 1)
|
||||
(LOOP
|
||||
(SETQ TERM (* M TERM P)
|
||||
M (+ M 2)
|
||||
NUMR (+ TERM (* NUMR Q M))
|
||||
DENR (* M Q DENR)
|
||||
BITLENGTH (- PRECISION (INTEGER-LENGTH NUMR)))
|
||||
( ((MINUSP BITLENGTH)
|
||||
(SETQ TERM (SHIFT TERM BITLENGTH)
|
||||
NUMR (SHIFT NUMR BITLENGTH)
|
||||
DENR (SHIFT DENR BITLENGTH)) ) )
|
||||
((ZEROP TERM)
|
||||
((ZEROP SHIFT)
|
||||
(/ NUMR DENR) )
|
||||
(+ (* SHIFT (GET-CONSTANT 'LN2 '(LN-AUX 2))) (/ NUMR DENR)) ) ) )
|
||||
|
||||
(IF (PLUSP (PRECISION)) (LN 2)) ;Initialize the variable LN2
|
||||
|
||||
|
||||
(DEFUN SQRT (N)
|
||||
;If n is positive, (SQRT n) returns square root of n.
|
||||
(EXPT N 1/2) )
|
||||
|
||||
|
||||
(DEFUN ISQRT (N)
|
||||
;If n is a nonnegative integer, (ISQRT n) returns the greatest integer
|
||||
;less than or equal to the positive square root of n.
|
||||
((INTEGERP N)
|
||||
((>= N 0)
|
||||
((= N 0) 0)
|
||||
(ISQRT-AUX N) )
|
||||
(BREAK (LIST 'ISQRT N) "Invalid Argument") )
|
||||
(BREAK (LIST 'ISQRT N) "Noninteger Argument") )
|
||||
|
||||
(DEFUN ISQRT-AUX (N
|
||||
;If n is a positive integer, (ISQRT-AUX n) returns the greatest integer
|
||||
;less than or equal to n^(1/2). ISQRT-AUX uses Newton's method.
|
||||
SHIFT INC ANS)
|
||||
(SETQ ANS 1
|
||||
INC 1
|
||||
SHIFT (* (- (TRUNCATE (SUB1 (INTEGER-LENGTH N)) 2)) 2) )
|
||||
(LOOP ;Start with 1-bit precision & repeatedly doubling
|
||||
((ZEROP SHIFT))
|
||||
(SETQ ANS (SHIFT ANS INC)
|
||||
SHIFT (+ SHIFT (SHIFT INC 1))
|
||||
ANS (+ ANS (FLOOR (- (SHIFT N SHIFT) (* ANS ANS)) (* 2 ANS)))
|
||||
INC (MIN (SHIFT INC 1) (TRUNCATE (- SHIFT) 2)) ) )
|
||||
((<= (* ANS ANS) N) ANS)
|
||||
(SUB1 ANS) )
|
||||
|
||||
(DEFUN PI ()
|
||||
;(PI) returns pi, accurate to the current precision.
|
||||
((PLUSP (PRECISION))
|
||||
(GET-CONSTANT 'PI '(PI-AUX)) )
|
||||
(BREAK (CONS 'PI) "Infinite Precision") )
|
||||
|
||||
(DEFUN PI-AUX (
|
||||
;(PI-AUX) returns pi, using the fact that 4/pi =
|
||||
;SIGMA ((-1)^m (1123 + 21460 m) (1 3 ...(2m-1)) (1 3 ...(4m-1))
|
||||
; / ((882^(2m+1) 32^m (m!)^3), m, 0, PINF), rearranged over a common
|
||||
;denominator (Ramanujan, Quart. J. Pure & Appl. Math. 45, p. 350, 1914).
|
||||
N M TERM NUMR DENR PRECISION BITLENGTH )
|
||||
(SETQ PRECISION (* 32 (PRECISION))
|
||||
M 0
|
||||
N 1123
|
||||
TERM 1
|
||||
NUMR 3528
|
||||
DENR N )
|
||||
(LOOP
|
||||
(INCQ M)
|
||||
(SETQ N (+ N 21460)
|
||||
TERM (* TERM (- (+ M M) 1) (- 1 (* 4 M)) (- (* 4 M) 3))
|
||||
BITLENGTH (* M M M 24893568)
|
||||
NUMR (* NUMR BITLENGTH)
|
||||
DENR (+ (* DENR BITLENGTH) (* N TERM))
|
||||
BITLENGTH (- (+ PRECISION (INTEGER-LENGTH N)) (INTEGER-LENGTH DENR)) )
|
||||
( ((MINUSP BITLENGTH)
|
||||
(SETQ TERM (SHIFT TERM BITLENGTH)
|
||||
DENR (SHIFT DENR BITLENGTH)
|
||||
NUMR (SHIFT NUMR BITLENGTH)) ) )
|
||||
((ZEROP TERM)
|
||||
(/ NUMR DENR) ) ) )
|
||||
|
||||
(IF (PLUSP (PRECISION)) (PI)) ;Initialize the variable PI
|
||||
|
||||
|
||||
(DEFUN SIN (N
|
||||
; (SIN n) returns the sine of n radians.
|
||||
Q )
|
||||
((NUMBERP N)
|
||||
((ZEROP N) 0)
|
||||
((PLUSP (PRECISION))
|
||||
(SETQ Q (/ N (/ (PI) 4))
|
||||
N (DIVIDE (NUMERATOR Q) (DENOMINATOR Q)))
|
||||
(SINCOS (MOD (CAR N) 8) (/ (CDR N) (DENOMINATOR Q))) )
|
||||
(BREAK (LIST 'SIN N) "Infinite Precision") )
|
||||
(BREAK (LIST 'SIN N) "Nonnumeric Argument") )
|
||||
|
||||
(DEFUN COS (N
|
||||
; (COS n) returns the cosine of n radians.
|
||||
Q )
|
||||
((NUMBERP N)
|
||||
((ZEROP N) 1)
|
||||
((PLUSP (PRECISION))
|
||||
(SETQ Q (/ N (/ (PI) 4))
|
||||
N (DIVIDE (NUMERATOR Q) (DENOMINATOR Q)))
|
||||
(SINCOS (MOD (+ 2 (CAR N)) 8) (/ (CDR N) (DENOMINATOR Q))) )
|
||||
(BREAK (LIST 'COS N) "Infinite Precision") )
|
||||
(BREAK (LIST 'COS N) "Nonnumeric Argument") )
|
||||
|
||||
(DEFUN TAN (N)
|
||||
; (TAN n) returns the tangent of n radians.
|
||||
(/ (SIN N) (COS N)) )
|
||||
|
||||
|
||||
(DEFUN SINCOS (N Q)
|
||||
; Returns the sine or cosine of an appropriately reduced angle.
|
||||
((> N 3)
|
||||
(- (SINCOS (- N 4) Q)) )
|
||||
((ZEROP N)
|
||||
(SETQ Q (* Q (/ (PI) 4)))
|
||||
(SINCOS-AUX Q 1 (NUMERATOR Q) (DENOMINATOR Q)) )
|
||||
((EQ N 1)
|
||||
(SINCOS-AUX (* (- 1 Q) (/ (PI) 4)) 0 1 1) )
|
||||
((EQ N 2)
|
||||
(SINCOS-AUX (* Q (/ (PI) 4)) 0 1 1) )
|
||||
(SETQ Q (* (- 1 Q) (/ (PI) 4)))
|
||||
(SINCOS-AUX Q 1 (NUMERATOR Q) (DENOMINATOR Q)) )
|
||||
|
||||
(DEFUN SINCOS-AUX (ARG N NUMR DENR
|
||||
; (SIN1 n) returns the sine of n radians, where 0 <= n <= pi/4 radians.
|
||||
; SIN (x=p/q) ~= x - x^3/3! + x^5/5! - ... +|- x^n/n! =
|
||||
; ((...((2*3pq^2 - p^3)4*5q^2 + p^5)6*7q^2 - ...)(n-1)nq^2 +|- p^n) / (n! q^n)
|
||||
; (COS1 n) returns the cosine of n radians, where 0 <= n <= pi/4 radians.
|
||||
; COS (x=p/q) ~= 1 - x^2/2! + x^3/3! - ... +|- x^n/n! =
|
||||
; ((...((2q^2 - p^2)3*4q^2 + p^4)5*6q^2 - ...)(n-1)nq^2 +|- p^n) / (n! q^n)
|
||||
MNARGSQ DARGSQ TERM PRECISION BITLENGTH )
|
||||
(SETQ PRECISION (* 32 (PRECISION))
|
||||
DARGSQ (* ARG ARG)
|
||||
MNARGSQ (- (NUMERATOR DARGSQ))
|
||||
DARGSQ (DENOMINATOR DARGSQ)
|
||||
TERM NUMR)
|
||||
(LOOP
|
||||
(SETQ N (+ N 2)
|
||||
ARG (* (SUB1 N) N)
|
||||
DENR (* ARG DARGSQ DENR)
|
||||
TERM (* MNARGSQ TERM)
|
||||
NUMR (+ (* ARG DARGSQ NUMR) TERM)
|
||||
BITLENGTH (- PRECISION (INTEGER-LENGTH NUMR)))
|
||||
( ((MINUSP BITLENGTH)
|
||||
(SETQ TERM (SHIFT TERM BITLENGTH)
|
||||
NUMR (SHIFT NUMR BITLENGTH)
|
||||
DENR (SHIFT DENR BITLENGTH)) ) )
|
||||
((ZEROP TERM)
|
||||
(/ NUMR DENR) ) ) )
|
||||
|
||||
|
||||
(DEFUN ASIN (N)
|
||||
; (ASIN n) returns the inverse sine of n in radians. Note that
|
||||
; for all -1 <= n <= 1, -pi/2 <= (ASIN n) <= pi/2.
|
||||
((NUMBERP N)
|
||||
((PLUSP (PRECISION))
|
||||
((MINUSP N)
|
||||
(- (ASIN (- N))) )
|
||||
((= N 1)
|
||||
(/ (PI) 2) )
|
||||
((< N 1)
|
||||
(ATAN (NUMERATOR N)
|
||||
(SQRT (* (- (DENOMINATOR N) (NUMERATOR N))
|
||||
(+ (DENOMINATOR N) (NUMERATOR N))))) )
|
||||
(BREAK (LIST 'ASIN N) "Invalid Argument") )
|
||||
(BREAK (LIST 'ASIN N) "Infinite Precision") )
|
||||
(BREAK (LIST 'ASIN N) "Nonnumeric Argument") )
|
||||
|
||||
(DEFUN ACOS (N)
|
||||
; (ACOS n) returns the inverse cosine of n in radians. Note that
|
||||
; for all -1 <= n <= 1, 0 <= (ACOS n) <= pi.
|
||||
((NUMBERP N)
|
||||
((= N 1) 0)
|
||||
((PLUSP (PRECISION))
|
||||
((= N -1)
|
||||
(PI) )
|
||||
((<= -1 N 1)
|
||||
((< (ABS N) 1)
|
||||
(ATAN (SQRT (* (- (DENOMINATOR N) (NUMERATOR N))
|
||||
(+ (DENOMINATOR N) (NUMERATOR N)) ))
|
||||
(NUMERATOR N)) ) )
|
||||
(BREAK (LIST 'ACOS N) "Invalid Argument") )
|
||||
(BREAK (LIST 'ACOS N) "Infinite Precision") )
|
||||
(BREAK (LIST 'ACOS N) "Nonnumeric Argument") )
|
||||
|
||||
|
||||
(DEFUN ATAN (N M
|
||||
; (ATAN n m) returns in radians the angle corresponding to the vector
|
||||
; whose opposite component is n and whose adjacent component is m.
|
||||
; m defaults to 1. Note that for all n and m, -pi < (ATAN n m) <= pi.
|
||||
; With v = x/(1+x^2) = r/s, u = xv = p/q, ATAN (x) ~=
|
||||
; (1 + 2u/3 + 2 4u^2/(3 5) +...+ 2 4 ...(2n)u^n/(3 5 ...(2n+1))) v =
|
||||
; ((...((3rq + 2rp)5q + 2 4rp^2)7q +...)(2n+1)q + 2 4 ...(2n)rp^n)
|
||||
; / (3 5 ...(2n+1)sq^n)
|
||||
INDX NUMR TERM DENR NARG DARG PRECISION BITLENGTH )
|
||||
((PLUSP (PRECISION))
|
||||
((NUMBERP N)
|
||||
((NUMBERP M) ;Reduce two-argument case to one argument
|
||||
((PLUSP M)
|
||||
(ATAN (/ N M)) )
|
||||
((ZEROP M)
|
||||
((PLUSP N)
|
||||
(/ (PI) 2) )
|
||||
((MINUSP N)
|
||||
(/ (PI) -2) )
|
||||
(BREAK (LIST 'ATAN N M) "Invalid Argument") )
|
||||
((ZEROP N)
|
||||
(PI) )
|
||||
((MINUSP N)
|
||||
(- (/ (PI) -2) (ATAN (/ M N))) )
|
||||
(+ (/ (PI) 2) (ATAN (/ (- M) N))) )
|
||||
((NULL M)
|
||||
((MINUSP N)
|
||||
(- (ATAN (- N))) )
|
||||
((> N 1)
|
||||
(- (/ (PI) 2) (ATAN (/ 1 N))) )
|
||||
(SETQ PRECISION (* 32 (PRECISION))
|
||||
M (/ N (ADD1 (* N N)))
|
||||
N (* N M)
|
||||
NARG (NUMERATOR N)
|
||||
DARG (DENOMINATOR N)
|
||||
INDX 1
|
||||
NUMR (NUMERATOR M)
|
||||
TERM NUMR
|
||||
DENR (DENOMINATOR M) )
|
||||
(LOOP
|
||||
(INCQ INDX 2)
|
||||
(SETQ TERM (* (SUB1 INDX) NARG TERM)
|
||||
NUMR (+ TERM (* INDX DARG NUMR))
|
||||
DENR (* INDX DARG DENR)
|
||||
BITLENGTH (- PRECISION (INTEGER-LENGTH NUMR)))
|
||||
( ((MINUSP BITLENGTH)
|
||||
(SETQ NUMR (SHIFT NUMR BITLENGTH)
|
||||
DENR (SHIFT DENR BITLENGTH)
|
||||
TERM (SHIFT TERM BITLENGTH)) ) )
|
||||
((ZEROP TERM)
|
||||
(/ NUMR DENR) ) ) )
|
||||
(BREAK (LIST 'ATAN N M) "Nonnumeric Argument") )
|
||||
(BREAK (LIST 'ATAN N M) "Nonnumeric Argument") )
|
||||
(BREAK (LIST 'ATAN N M) "Infinite Precision") )
|
||||
|
||||
|
||||
; Section 5.12.7: Bitwise Logical Functions
|
||||
|
||||
(MOVD 'SHIFT 'ASH)
|
||||
|
||||
|
||||
; Section 5.12.8: Random Numbers
|
||||
|
||||
(DEFUN RANDOM (N STATE
|
||||
BL COUNT ANS)
|
||||
(IF (RANDOM-STATE-P STATE)
|
||||
(SETQ *RANDOM-STATE* STATE) )
|
||||
(SETQ *RANDOM-STATE*
|
||||
(LOGAND (ADD1 (* 3141592653 *RANDOM-STATE*)) 4294967295))
|
||||
((AND (INTEGERP N) (PLUSP N))
|
||||
(SETQ ANS *RANDOM-STATE*
|
||||
BL (- -10 (INTEGER-LENGTH N))
|
||||
COUNT 0)
|
||||
(LOOP ; concatenate 32-bit random integers
|
||||
((> BL (DECQ COUNT 32))
|
||||
(SHIFT (* N ANS) COUNT) )
|
||||
(SETQ *RANDOM-STATE*
|
||||
(LOGAND (ADD1 (* 3141592653 *RANDOM-STATE*)) 4294967295)
|
||||
ANS (+ (SHIFT ANS 32) *RANDOM-STATE*)) ) )
|
||||
((NUMBERP N)
|
||||
(SETQ ANS (SHIFT 1 (- (* 32 (MAX (PRECISION) 1)) 10)))
|
||||
(/ (* (ABS N) (RANDOM ANS)) ANS) ) )
|
||||
|
||||
(DEFUN MAKE-RANDOM-STATE (STATE)
|
||||
((NULL STATE) *RANDOM-STATE*)
|
||||
((EQ STATE 'T)
|
||||
(TIME) )
|
||||
((RANDOM-STATE-P STATE) STATE) )
|
||||
|
||||
(SETQ *RANDOM-STATE* (MAKE-RANDOM-STATE 'T))
|
||||
|
||||
(DEFUN RANDOM-STATE-P (OBJ)
|
||||
(AND (INTEGERP OBJ) (>= OBJ 0)) )
|
||||
|
||||
|
||||
; Section 5.13.2: Input Functions
|
||||
|
||||
(SETQ *LPAR* '\()
|
||||
(SETQ *RPAR* '\))
|
||||
|
||||
(DEFUN READ-BACKQUOTE (
|
||||
; This backquote facility conforms to the Common LISP standard except
|
||||
; that nested backquote forms are not supported. See Section 22.1.3
|
||||
; of Common LISP by Steele [1984].
|
||||
CHAR FORM-LIST )
|
||||
(SETQ CHAR (PEEK-CHAR T))
|
||||
((EQ CHAR '\,)
|
||||
(READ-CHAR)
|
||||
(SETQ CHAR (PEEK-CHAR))
|
||||
((OR (EQ CHAR '\@) (EQ CHAR '\.))
|
||||
(BREAK CHAR "Syntax Error") )
|
||||
(READ) )
|
||||
((NEQ CHAR *LPAR*)
|
||||
(LIST 'QUOTE (READ)) )
|
||||
(READ-CHAR)
|
||||
(LOOP
|
||||
(SETQ CHAR (PEEK-CHAR T))
|
||||
((EQ CHAR *RPAR*)
|
||||
(READ-CHAR)
|
||||
((NULL FORM-LIST) NIL)
|
||||
((NULL (CDR FORM-LIST))
|
||||
(CAR FORM-LIST) )
|
||||
(CONS 'NCONC (NREVERSE FORM-LIST)) )
|
||||
((EQ CHAR '\.)
|
||||
(READ-CHAR)
|
||||
(SETQ CHAR (PEEK-CHAR T))
|
||||
((EQ CHAR '\,)
|
||||
(READ-CHAR)
|
||||
(SETQ CHAR (PEEK-CHAR))
|
||||
((OR (EQ CHAR '\@) (EQ CHAR '\.))
|
||||
(BREAK CHAR "Syntax Error") )
|
||||
(PUSH (READ) FORM-LIST)
|
||||
((EQ (READ-CHAR) *RPAR*)
|
||||
(CONS 'NCONC (NREVERSE FORM-LIST)) )
|
||||
(BREAK '\. "Syntax Error") )
|
||||
(PUSH (READ-BACKQUOTE) FORM-LIST)
|
||||
((EQ (READ-CHAR) *RPAR*)
|
||||
(CONS 'NCONC (NREVERSE FORM-LIST)) )
|
||||
(BREAK '\. "Syntax Error") )
|
||||
( ((EQ CHAR '\,)
|
||||
(READ-CHAR)
|
||||
(SETQ CHAR (PEEK-CHAR))
|
||||
((EQ CHAR '\@)
|
||||
(READ-CHAR)
|
||||
(PUSH (READ) FORM-LIST)
|
||||
((EQ (PEEK-CHAR T) *RPAR*))
|
||||
(PUSH (LIST 'COPY-LIST (POP FORM-LIST)) FORM-LIST) )
|
||||
((EQ CHAR '\.)
|
||||
(READ-CHAR)
|
||||
(PUSH (READ) FORM-LIST) )
|
||||
(PUSH (LIST 'LIST (READ)) FORM-LIST) )
|
||||
(PUSH (LIST 'LIST (READ-BACKQUOTE)) FORM-LIST) ) ) )
|
||||
|
||||
(SET-MACRO-CHAR '\` '(LAMBDA ()
|
||||
(READ-BACKQUOTE) ))
|
||||
|
||||
|
||||
; Section 5.15.1: Evaluation Recognizers
|
||||
|
||||
(DEFUN EVAL-FUNCTION-P (SYM)
|
||||
(EQ (GETD SYM T) 'LAMBDA) )
|
||||
|
||||
(DEFUN NO-EVAL-FUNCTION-P (SYM)
|
||||
(EQ (GETD SYM T) 'NLAMBDA) )
|
||||
|
||||
(DEFUN MACRO-FUNCTION-P (SYM)
|
||||
(EQ (GETD SYM T) 'MACRO) )
|
||||
|
||||
(DEFUN SPECIAL-FORM-P (SYM)
|
||||
(EQ (GETD SYM T) 'SPECIAL) )
|
||||
|
||||
(DEFUN FBOUNDP (SYM)
|
||||
(GETD SYM T) )
|
||||
|
||||
(DEFUN FUNCTIONP (OBJ)
|
||||
((SYMBOLP OBJ))
|
||||
((ATOM OBJ) NIL)
|
||||
(EQ (CAR OBJ) 'LAMBDA) )
|
||||
|
||||
|
||||
; Section 5.15.2: Evaluation and Function Application
|
||||
|
||||
(DEFUN SYMBOL-VALUE (SYM)
|
||||
((SYMBOLP SYM)
|
||||
(CAR SYM) ) )
|
||||
|
||||
(DEFUN SYMBOL-PLIST (SYM)
|
||||
((SYMBOLP SYM)
|
||||
(CDR SYM) ) )
|
||||
|
||||
(DEFUN SYMBOL-FUNCTION (SYM)
|
||||
((SYMBOLP SYM)
|
||||
((FBOUNDP SYM)
|
||||
(GETD SYM) )
|
||||
(BREAK (LIST 'SYMBOL-FUNCTION SYM) "Undefined Function") ) )
|
||||
|
||||
|
||||
; Section 5.15.3: Macro Expansion Functions
|
||||
|
||||
(DEFUN MACRO-FUNCTION (SYM)
|
||||
((MACRO-FUNCTION-P SYM)
|
||||
(GETD SYM) ) )
|
||||
|
||||
|
||||
; Section 5.16: Control Constructs
|
||||
|
||||
(DEFMACRO PROG2 (FORM1 . FORMS)
|
||||
(LIST 'PROGN FORM1 (CONS 'PROG1 FORMS)) )
|
||||
|
||||
(DEFMACRO WHEN (TEST . BODY)
|
||||
(LIST 'IF TEST (CONS 'PROGN BODY)) )
|
||||
|
||||
(DEFMACRO UNLESS (TEST . BODY)
|
||||
(LIST 'IF TEST NIL (CONS 'PROGN BODY)) )
|
||||
|
||||
(DEFMACRO LET (LETLIST . BODY)
|
||||
(CONS (LIST* 'LAMBDA
|
||||
(MAPCAR 'CAR LETLIST)
|
||||
BODY)
|
||||
(MAPCAR 'CADR LETLIST)) )
|
||||
|
||||
(DEFMACRO LET* (LETLIST . BODY)
|
||||
(LIST (LIST* 'LAMBDA
|
||||
(MAPCAR 'CAR LETLIST)
|
||||
(CONS 'SETQ
|
||||
(MAPCAN '(LAMBDA (LST) (LIST (CAR LST) (CADR LST)))
|
||||
LETLIST))
|
||||
BODY)) )
|
||||
|
||||
(DEFMACRO DO (LETLIST . BODY)
|
||||
(CONS (LIST 'LAMBDA
|
||||
(MAPCAR '(LAMBDA (VAR) (IF (ATOM VAR) VAR (CAR VAR))) LETLIST)
|
||||
(CONS 'LOOP
|
||||
(APPEND BODY (LIST (CONS 'PSETQ
|
||||
(MAPCAN '(LAMBDA (VAR)
|
||||
((ATOM VAR) NIL)
|
||||
((CADDR VAR)
|
||||
(LIST (CAR VAR) (CADDR VAR)) ) )
|
||||
LETLIST))))))
|
||||
(MAPCAR '(LAMBDA (VAR) (IF (ATOM VAR) NIL (CADR VAR))) LETLIST)) )
|
||||
|
||||
(DEFMACRO DO* (LETLIST . BODY)
|
||||
(LIST (LIST 'LAMBDA
|
||||
(MAPCAR '(LAMBDA (VAR) (IF (ATOM VAR) VAR (CAR VAR)))
|
||||
LETLIST)
|
||||
(CONS 'SETQ
|
||||
(MAPCAN '(LAMBDA (VAR)
|
||||
((ATOM VAR)
|
||||
(LIST VAR NIL) )
|
||||
(LIST (CAR VAR) (CADR VAR)))
|
||||
LETLIST))
|
||||
(CONS 'LOOP
|
||||
(APPEND BODY (LIST (CONS 'SETQ
|
||||
(MAPCAN '(LAMBDA (VAR)
|
||||
((ATOM VAR) NIL)
|
||||
((CADDR VAR)
|
||||
(LIST (CAR VAR) (CADDR VAR)) ) )
|
||||
LETLIST))))))) )
|
||||
|
||||
(DEFMACRO DOLIST ((VAR LISTFORM RSLTFORM) . BODY)
|
||||
(LET ((DOLIST (GENSYM)))
|
||||
(LIST 'LET
|
||||
(LIST (LIST DOLIST LISTFORM))
|
||||
(LIST* 'LOOP
|
||||
(LIST (LIST 'ATOM DOLIST) RSLTFORM)
|
||||
(LIST 'SETQ VAR (LIST 'POP DOLIST))
|
||||
BODY)) ) )
|
||||
|
||||
(DEFMACRO DOTIMES ((VAR COUNTFORM RSLTFORM) . BODY)
|
||||
(LET ((DOTIMES (GENSYM)))
|
||||
(LIST 'LET
|
||||
(LIST (LIST VAR 0)
|
||||
(LIST DOTIMES COUNTFORM))
|
||||
(LIST* 'LOOP
|
||||
(LIST (LIST '>= VAR DOTIMES) RSLTFORM)
|
||||
(APPEND BODY (LIST (LIST 'INCQ VAR))))) ) )
|
||||
|
||||
|
||||
; PROG [var-list, expn1, expn2, ..., expnm] sets the local variables
|
||||
; in <var-list> to NIL and sequentially evaluates <expn1> through <expnm>,
|
||||
; unless the functions GO or RETURN are encountered. This PROG interpreter
|
||||
; is included for completeness. We strongly recommend that functions using
|
||||
; PROG be translated into equivalent muLISP functions using the LOOP
|
||||
; construct, since the resulting function will be much more efficient.
|
||||
|
||||
(DEFUN PROG (NLAMBDA LST$
|
||||
(EVAL (LIST (CONS 'LAMBDA (LIST (CAR LST$) (LIST 'PROG-AUX
|
||||
'(CDR LST$)))))) ))
|
||||
|
||||
(DEFUN PROG-AUX (BDY$
|
||||
LST$ GO-LABEL$ ANS$)
|
||||
(SETQ LST$ BDY$)
|
||||
(LOOP
|
||||
((NULL LST$) ANS$)
|
||||
(SETQ ANS$ (EVAL (POP LST$)))
|
||||
( ((NULL GO-LABEL$))
|
||||
(SETQ LST$ (CDR (MEMBER GO-LABEL$ BDY$))
|
||||
GO-LABEL$) ) ) )
|
||||
|
||||
|
||||
;GO [label] if within a PROG, transfers control to the expression in
|
||||
;the PROG body immediately following <label>.
|
||||
|
||||
(DEFUN GO (NLAMBDA (LABEL$)
|
||||
(SETQ GO-LABEL$ LABEL$) ))
|
||||
|
||||
|
||||
(SETQ *COMMMAND-DRIVE* "")
|
||||
|
||||
(DEFUN DOS (COMMAND
|
||||
; (DOS command) executes the MS-DOS <command>, and returns the exit code.
|
||||
; If the MS-DOS command processor is not on the default drive, the user
|
||||
; is prompted for the drive containing COMMAND.COM. See the EXECUTE
|
||||
; function in Section 5.16 for an example using DOS.
|
||||
READ-CHAR RDS WRS )
|
||||
(LOOP
|
||||
((EXECUTE (PACK* *COMMAND-DRIVE* "COMMAND.COM")
|
||||
(IF COMMAND (PACK* "/C " COMMAND))))
|
||||
(FRESH-LINE)
|
||||
(WRITE-STRING "Enter COMMAND.COM drive letter: ")
|
||||
(SETQ *COMMAND-DRIVE* (PRINC (CHAR-UPCASE (READ-CHAR))))
|
||||
(TERPRI)
|
||||
((NOT (ALPHA-CHAR-P *COMMAND-DRIVE*)) NIL)
|
||||
(SETQ *COMMAND-DRIVE* (PACK* *COMMAND-DRIVE* '\:)) ) )
|
||||
|
||||
|
||||
; Section 22.4: Querying the User
|
||||
|
||||
(DEFUN Y-OR-N-P (MSG
|
||||
CHAR READ-CHAR RDS WRS )
|
||||
( ((NULL MSG))
|
||||
(FRESH-LINE)
|
||||
(WRITE-STRING (PACK* MSG " (Y/N) ")) )
|
||||
(CLEAR-INPUT)
|
||||
(LOOP
|
||||
(SETQ CHAR (CHAR-UPCASE (READ-CHAR)))
|
||||
((EQ CHAR 'Y) (WRITE-LINE CHAR) T)
|
||||
((EQ CHAR 'N) (WRITE-LINE CHAR) NIL)
|
||||
(WRITE-BYTE 7) ) )
|
||||
|
||||
(DEFUN YES-OR-NO-P (MSG
|
||||
LINE READ-CHAR RDS WRS )
|
||||
(SETQ READ-CHAR T)
|
||||
(CLEAR-INPUT)
|
||||
(LOOP
|
||||
( ((NULL MSG))
|
||||
(FRESH-LINE)
|
||||
(WRITE-STRING (PACK* MSG " (Yes or No) ")) )
|
||||
(WRITE-BYTE 7)
|
||||
(SETQ LINE (CHAR-UPCASE (READ-LINE)))
|
||||
((EQ LINE 'YES) T)
|
||||
((EQ LINE 'NO) NIL) ) )
|
||||
|
||||
(RDS)
|
||||
|
||||
BIN
Microsoft muLISP-86 v51/COMTOEXE.COM
Normal file
BIN
Microsoft muLISP-86 v51/COMTOEXE.COM
Normal file
Binary file not shown.
244
Microsoft muLISP-86 v51/DEBUG.LSP
Normal file
244
Microsoft muLISP-86 v51/DEBUG.LSP
Normal file
@ -0,0 +1,244 @@
|
||||
; File: DEBUG.LSP (c) 08/15/85 Soft Warehouse, Inc.
|
||||
|
||||
|
||||
(LOOP (PRIN1 '*) (EVAL (READ)) ((NULL RDS)) )
|
||||
|
||||
|
||||
(DEFUN TRACE LST
|
||||
(STUB 'TRACE LST) )
|
||||
|
||||
(DEFUN BRK LST
|
||||
(STUB 'BRK LST) )
|
||||
|
||||
(DEFUN CLEAR LST
|
||||
(UNSTUB LST) )
|
||||
|
||||
(DEFUN HISTORY (
|
||||
LST)
|
||||
(SETQ! LST (CAR! HISTORY))
|
||||
(LOOP!
|
||||
((EQ! LST))
|
||||
( ((EQ! (CAR! LST)))
|
||||
(APPLY! (CAR! (CAR! LST)) (CDR! (CAR! LST))) )
|
||||
(POP! LST) ) )
|
||||
|
||||
(SETQ HISTLEN 15)
|
||||
|
||||
(DEFUN BACKTRACE (
|
||||
LST)
|
||||
(SETQ! LST (REVERSE! BTRLIST))
|
||||
(LOOP!
|
||||
((EQ! LST))
|
||||
(APPLY! PRTCALL! (LIST! (CAR! (CAR! LST)) (CDR! (POP! LST)))) ) )
|
||||
|
||||
(DEFUN STUB (FLAG LST NAM
|
||||
NAM$)
|
||||
(SET FLAG T)
|
||||
(SETQ NAM$ T)
|
||||
(LOOP
|
||||
((ATOM LST) NAM$)
|
||||
(SETQ NAM (POP LST))
|
||||
( ((NOT (GETD NAM T))
|
||||
(SETQ NAM$)
|
||||
(PRIN1 NAM) (WRITE-LINE " is undefined") )
|
||||
(FLAG FLAG NAM)
|
||||
((TRACED NAM))
|
||||
(PUT NAM 'DEBUG (CONS! (PACK* NAM '!) (COND
|
||||
((NUMBERP (GETD NAM)) NIL)
|
||||
((CADR (GETD NAM))) )))
|
||||
(MOVD NAM (CAR! (GET NAM 'DEBUG)))
|
||||
(PUTD NAM (LIST
|
||||
(IF (EQ (GETD NAM T) 'SPECIAL) 'NLAMBDA (GETD NAM T))
|
||||
'ARGLST! (LIST 'TRACE! NAM))) ) ) )
|
||||
|
||||
(DEFUN TRACED (NAM)
|
||||
(EQ (CAR (CADDR (GETD NAM))) 'TRACE!) )
|
||||
|
||||
(DEFUN UNSTUB (LST NAM)
|
||||
(SETQ LEVELCOUNT 0)
|
||||
(RPLACD 'LEVELCOUNT)
|
||||
(SETQ BTRLIST)
|
||||
(LOOP
|
||||
((ATOM LST))
|
||||
(SETQ NAM (POP LST))
|
||||
( ((GET NAM 'DEBUG)
|
||||
(REMFLAG 'BRK NAM)
|
||||
(REMFLAG 'TRACE NAM)
|
||||
(MOVD (CAR! (GET NAM 'DEBUG)) NAM)
|
||||
(REMPROP NAM 'DEBUG) ) ) ) )
|
||||
|
||||
|
||||
(DEFUN TRACE! (NLAMBDA (NAM!
|
||||
LST!)
|
||||
( ((AND! (EQ! LEVELCOUNT 0) RATOM)
|
||||
(SETQ! RATOM)
|
||||
(SETQ! HISTORY)
|
||||
(SETQ! CALLCOUNT 0)
|
||||
(RPLACD! 'CALLCOUNT)
|
||||
(SETQ! MAXLEVELCOUNT 0)
|
||||
(RPLACD! 'MAXLEVELCOUNT) ) )
|
||||
(PUTADD! 'CALLCOUNT NAM!)
|
||||
(PUTADD! 'LEVELCOUNT NAM!)
|
||||
( ((<! LEVELCOUNT MAXLEVELCOUNT))
|
||||
(SETQ! MAXLEVELCOUNT LEVELCOUNT) )
|
||||
( ((AND! (NUMBERP! (GET! 'MAXLEVELCOUNT NAM!))
|
||||
(<! (GET! 'LEVELCOUNT NAM!) (GET! 'MAXLEVELCOUNT NAM!))))
|
||||
(PUT! 'MAXLEVELCOUNT NAM! (GET! 'LEVELCOUNT NAM!)) )
|
||||
( ((EQ! BACKTRACE))
|
||||
(PUSH! (CONS! NAM! ARGLST!) BTRLIST) )
|
||||
(HISTORY! NAM! ARGLST! LEVELCOUNT 'PRTCALL!)
|
||||
( ((TRACEP! NAM!)
|
||||
(PRTCALL! NAM! ARGLST! LEVELCOUNT) ) )
|
||||
( ((AND! BRK
|
||||
(FLAGP! 'BRK NAM!)
|
||||
(LEQ! MINCALL CALLCOUNT)
|
||||
(LEQ! (GET! 'MINCALL NAM!) (GET! 'CALLCOUNT NAM!))
|
||||
(OR! (EQ! (NUMBERP! BRKLEVEL))
|
||||
(EQ! LEVELCOUNT BRKLEVEL) )
|
||||
(OR! (EQ! (NUMBERP! (GET! 'BRKLEVEL NAM!)))
|
||||
(EQ! (GET! 'LEVELCOUNT NAM!) (GET! 'BRKLEVEL NAM!)))
|
||||
(OR! (EQ! (SETQ! LST! (GET! 'DEBUGIN NAM!)))
|
||||
(LOOP!
|
||||
((ATOM! LST!) NIL)
|
||||
((ASSOC! (POP! LST!) BTRLIST)) )) )
|
||||
(TERPRI!)
|
||||
(PRINC! "Break-point: ")
|
||||
(PRTCALL! NAM! ARGLST!)
|
||||
(SETQ! LST! (BREAK!)) ) )
|
||||
((EQ! (EQ! LST!)))
|
||||
(SETQ! ARGLST! (APPLY! (CAR! (GET! NAM! 'DEBUG)) ARGLST!))
|
||||
(HISTORY! NAM! ARGLST! LEVELCOUNT 'PRTRSLT!)
|
||||
( ((TRACEP! NAM!)
|
||||
(PRTRSLT! NAM! ARGLST! LEVELCOUNT) ) )
|
||||
( ((EQ! NAM! (CAR! (CAR! BTRLIST)))
|
||||
(POP! BTRLIST) ) )
|
||||
(PUTSUB! 'LEVELCOUNT NAM!)
|
||||
ARGLST! ))
|
||||
|
||||
(DEFUN TRACEP! (NAM!
|
||||
LST!)
|
||||
(AND! TRACE
|
||||
(FLAGP! 'TRACE NAM!)
|
||||
(LEQ! MINCALL CALLCOUNT)
|
||||
(LEQ! MINLEVEL LEVELCOUNT)
|
||||
(LEQ! LEVELCOUNT MAXLEVEL)
|
||||
(LEQ! (GET! 'MINLEVEL NAM!) (GET! 'LEVELCOUNT NAM!))
|
||||
(LEQ! (GET! 'LEVELCOUNT NAM!) (GET! 'MAXLEVEL NAM!))
|
||||
(OR! (EQ! (SETQ! LST! (GET! 'DEBUGIN NAM!)))
|
||||
(LOOP!
|
||||
((ATOM! LST!) NIL)
|
||||
((ASSOC! (POP! LST!) BTRLIST)) ) ) ) )
|
||||
|
||||
(DEFUN LEQ! (NUM1 NUM2)
|
||||
(OR! (EQ! (NUMBERP! NUM1))
|
||||
(EQ! (NUMBERP! NUM2))
|
||||
(EQ! NUM1 NUM2)
|
||||
(<! NUM1 NUM2) ) )
|
||||
|
||||
(DEFUN HISTORY! (NAM LST NUM NAM1)
|
||||
(SETQ! HISTORY (TCONC! HISTORY (LIST! NAM1 NAM LST NUM)))
|
||||
((<! HISTLEN (LENGTH! (CAR! HISTORY)))
|
||||
(RPLACA! HISTORY (CDR! (CAR! HISTORY))) ) )
|
||||
|
||||
(DEFUN PUTADD! (NAM1 NAM2)
|
||||
((EQ! (NUMBERP! (CAR! NAM1))))
|
||||
(SET! NAM1 (+! (CAR! NAM1) 1))
|
||||
((NUMBERP! (GET! NAM1 NAM2))
|
||||
(PUT! NAM1 NAM2 (+! (GET! NAM1 NAM2) 1)) )
|
||||
(PUT! NAM1 NAM2 1) )
|
||||
|
||||
(DEFUN PUTSUB! (NAM1 NAM2)
|
||||
((EQ! (NUMBERP! (CAR! NAM1))))
|
||||
( ((EQ! (CAR! NAM1) 0))
|
||||
(SET! NAM1 (+! (CAR! NAM1) -1)) )
|
||||
((NUMBERP! (GET NAM1 NAM2))
|
||||
((<! 0 (GET NAM1 NAM2))
|
||||
((EQ! (GET NAM1 NAM2) 1)
|
||||
(REMPROP! NAM1 NAM2) )
|
||||
(PUT! NAM1 NAM2 (+! (GET! NAM1 NAM2) -1)) ) ) )
|
||||
|
||||
(DEFUN PRTCALL! (NAM LST NUM)
|
||||
(PRTNAM!)
|
||||
(SETQ! NAM (CDR! (GET! NAM 'DEBUG)))
|
||||
(PRINC! '"[")
|
||||
( ((EQ! NAM)
|
||||
((ATOM! LST))
|
||||
(LOOP!
|
||||
(PRTEXP! NAM (POP! LST))
|
||||
((ATOM! LST))
|
||||
(PRINC! ", ") ) )
|
||||
((ATOM! NAM)
|
||||
(PRINC! NAM)
|
||||
(PRINC! ": ")
|
||||
(PRTEXP! NAM LST) )
|
||||
(LOOP!
|
||||
(PRINC! (CAR! NAM))
|
||||
(PRINC! ": ")
|
||||
(PRTEXP! (POP! NAM) (POP! LST))
|
||||
((ATOM! NAM)
|
||||
((ATOM! LST))
|
||||
(LOOP!
|
||||
(PRTEXP! NAM (POP! LST))
|
||||
((ATOM! LST))
|
||||
(PRINC! ", ") ) )
|
||||
(PRINC! ", ") ) )
|
||||
(PRINC! '"]")
|
||||
(TERPRI!) )
|
||||
|
||||
(DEFUN PRTRSLT! (NAM LST NUM)
|
||||
(PRTNAM!)
|
||||
(PRINC! "= ")
|
||||
(PRTEXP! NAM LST)
|
||||
(TERPRI!) )
|
||||
|
||||
(DEFUN PRTNAM! ()
|
||||
( ((NUMBERP! NUM)
|
||||
(FRESH-LINE)
|
||||
( ((<! NUM 10)
|
||||
(SPACES! 1) ) )
|
||||
(PRINC! NUM)
|
||||
(PRINC! '"|")
|
||||
(SPACES! NUM) ) )
|
||||
(PRINC! NAM)
|
||||
(SPACES! 1) )
|
||||
|
||||
(DEFUN PRTEXP! (NAM EXP)
|
||||
(PRINC! EXP) )
|
||||
|
||||
|
||||
(MOVD 'CAR 'CAR!)
|
||||
(MOVD 'CDR 'CDR!)
|
||||
(MOVD 'ASSOC 'ASSOC!)
|
||||
(MOVD 'CONS 'CONS!)
|
||||
(MOVD 'LIST 'LIST!)
|
||||
(MOVD 'REVERSE 'REVERSE!)
|
||||
(MOVD 'RPLACA 'RPLACA!)
|
||||
(MOVD 'RPLACD 'RPLACD!)
|
||||
(MOVD 'TCONC 'TCONC!)
|
||||
(MOVD 'GET 'GET!)
|
||||
(MOVD 'PUT 'PUT!)
|
||||
(MOVD 'REMPROP 'REMPROP!)
|
||||
(MOVD 'FLAGP 'FLAGP!)
|
||||
(MOVD 'ATOM 'ATOM!)
|
||||
(MOVD 'NUMBERP 'NUMBERP!)
|
||||
(MOVD 'EQ 'EQ!)
|
||||
(MOVD '< '<!)
|
||||
(MOVD 'SET 'SET!)
|
||||
(MOVD 'SETQ 'SETQ!)
|
||||
(MOVD '+ '+!)
|
||||
(MOVD 'LENGTH 'LENGTH!)
|
||||
(MOVD 'PRINC 'PRINC!)
|
||||
(MOVD 'TERPRI 'TERPRI!)
|
||||
(MOVD 'SPACES 'SPACES!)
|
||||
(MOVD 'APPLY 'APPLY!)
|
||||
(MOVD 'BREAK 'BREAK!)
|
||||
(MOVD 'LOOP 'LOOP!)
|
||||
(MOVD 'AND 'AND!)
|
||||
(MOVD 'OR 'OR!)
|
||||
(MOVD 'POP 'POP!)
|
||||
(MOVD 'PUSH 'PUSH!)
|
||||
|
||||
(CLEAR)
|
||||
|
||||
(RDS)
|
||||
|
||||
956
Microsoft muLISP-86 v51/DOCTOR.LSP
Normal file
956
Microsoft muLISP-86 v51/DOCTOR.LSP
Normal file
@ -0,0 +1,956 @@
|
||||
;File: DOCTOR.LSP 12/27/85 Soft Warehouse, Inc.
|
||||
|
||||
|
||||
(PROGN
|
||||
(TERPRI 2)
|
||||
(PRINC "Please relax while the Doctor is reviewing your records.")
|
||||
(TERPRI)
|
||||
(PRINC "He will be ready to talk to you in just a few seconds.")
|
||||
(TERPRI 2)
|
||||
(PRINC " - the Doctor's secretary")
|
||||
(TERPRI 2)
|
||||
(LOOP (PRINC '*) (EVAL (READ)) ((NULL RDS)) ) )
|
||||
|
||||
|
||||
(DEFUN DOCTOR (FILE
|
||||
SENTENCE KEYSTACK MEMSTACK FLIPFLOP CTR)
|
||||
( ((NULL FILE))
|
||||
(WRS (CAR FILE) (CADR FILE) (CADDR FILE))
|
||||
(SETQ ECHO T) )
|
||||
(TERPRI 2)
|
||||
(PRINC "D: I am at your service; just tell me anything that troubles")
|
||||
(TERPRI)
|
||||
(PRINC " or concerns you. Please end your sentences with a period,")
|
||||
(TERPRI)
|
||||
(PRINC " a question mark, or an exclamation mark, and then press the")
|
||||
(TERPRI)
|
||||
(PRINC " RETURN or ENTER key. When you are ready to quit our session,")
|
||||
(TERPRI)
|
||||
(PRINC " just enter \"GOODBYE.\" and press the RETURN or ENTER key.")
|
||||
(TERPRI 2)
|
||||
(SETNONE)
|
||||
(LOOP
|
||||
(PRINC '"P: ")
|
||||
(SETQ SENTENCE (MAKSEN (READSENT)))
|
||||
(SETQ KEYSTACK (CDR SENTENCE))
|
||||
(SETQ SENTENCE (CAR SENTENCE))
|
||||
(TERPRI)
|
||||
(PRINC '"D: ")
|
||||
((MEMBER 'GOODBYE SENTENCE))
|
||||
(SETQ CTR 800)
|
||||
(LOOP ((ZEROP (DECQ CTR)))) ;An optional short pause
|
||||
(PRTSENT (ANALYZE))
|
||||
(TERPRI)
|
||||
(MEMORY) )
|
||||
(PRINC "I hope I have been of some service, let's get together")
|
||||
(TERPRI)
|
||||
(PRINC " again sometime.")
|
||||
(TERPRI)
|
||||
'"" )
|
||||
|
||||
|
||||
(DEFUN MAKSEN (SENTENCE WORD FLAG RULE KEYSTACK)
|
||||
(SETQ KEYSTACK (CONS))
|
||||
(LOOP
|
||||
((NULL SENTENCE)
|
||||
(CONS (REVERSE RULE) KEYSTACK) )
|
||||
(SETQ WORD (CAR SENTENCE))
|
||||
( ((NUMBERP WORD)
|
||||
(SETQ WORD (COND
|
||||
((ZEROP WORD) ZERO)
|
||||
((EQ WORD 1) ONE)
|
||||
((EQ WORD 2) TWO)
|
||||
(NUMBER) )) ) )
|
||||
((MEMBER WORD PCTLIS)
|
||||
(SETQ FLAG (MAKSEN (CDR SENTENCE)))
|
||||
((NULL (CDR KEYSTACK)) FLAG)
|
||||
((AND (CDDR FLAG) (NOT (>
|
||||
(GETP (CDR KEYSTACK) 'PRIORITY)
|
||||
(GETP (CDDR FLAG) 'PRIORITY) )))
|
||||
FLAG )
|
||||
(CONS (REVERSE RULE) KEYSTACK) )
|
||||
( ((GETP WORD 'MEMR)
|
||||
(SETQ MEMSTACK (APPEND (GETP WORD 'MEMR) MEMSTACK)) ) )
|
||||
( ((GETP WORD 'PRIORITY)
|
||||
((AND (CDR KEYSTACK) (> (GETP WORD 'PRIORITY)
|
||||
(GETP (CDR KEYSTACK) 'PRIORITY) ))
|
||||
(RPLACD KEYSTACK (CONS (CDR KEYSTACK) (CDR WORD))) )
|
||||
(BCONC (CDR WORD) KEYSTACK) ) )
|
||||
(SETQ WORD (COND
|
||||
((GETP WORD 'TRANSLATION))
|
||||
(WORD) ))
|
||||
(PUSH WORD RULE)
|
||||
(POP SENTENCE) ) )
|
||||
|
||||
(DEFUN ANALYZE (RULES PARSLST CR EXIT)
|
||||
(SETQ FLIPFLOP (NOT FLIPFLOP))
|
||||
(BCONC (GETP 'NONE (COND
|
||||
((NULL FLIPFLOP)
|
||||
'MEM )
|
||||
('LASTRESORT) ))
|
||||
KEYSTACK )
|
||||
(POP KEYSTACK)
|
||||
(SETQ RULES (GETP KEYSTACK 'RULES))
|
||||
(LOOP
|
||||
(SETQ EXIT NIL)
|
||||
( ((OR (NULL RULES) (EQ (CAR RULES) 'NEWKEY))
|
||||
(SETQ KEYSTACK (CAR KEYSTACK))
|
||||
(SETQ RULES (GETP KEYSTACK 'RULES)) )
|
||||
((ATOM (CAR RULES))
|
||||
(SETQ RULES (GETP (CAR RULES) 'RULES)) )
|
||||
(SETQ PARSLST (CONS))
|
||||
((NOT (TEST (CAAR RULES) SENTENCE))
|
||||
(POP RULES) )
|
||||
(SETQ RULES (CAR (ADVANCE RULES)))
|
||||
(SETQ CR (CAR RULES))
|
||||
((ATOM CR))
|
||||
((EQ (CAR CR) 'PRE)
|
||||
(SETQ SENTENCE (RECONSTRUCT (CADR CR) PARSLST))
|
||||
(SETQ RULES (CDDR CR)) )
|
||||
(SETQ EXIT T) )
|
||||
((EVAL EXIT)
|
||||
(RECONSTRUCT CR PARSLST) ) ) )
|
||||
|
||||
(DEFUN MEMORY (PARSLST X)
|
||||
(LOOP
|
||||
((NULL MEMSTACK))
|
||||
(SETQ PARSLST (CONS))
|
||||
( ((TEST (CAAR MEMSTACK) SENTENCE)
|
||||
(SETQ X (CDAR (CADR (GETP 'NONE 'MEM))))
|
||||
(RPLACA X (CONS (CAR X) (CONS
|
||||
(RECONSTRUCT (CAAR (ADVANCE MEMSTACK)) PARSLST)
|
||||
(CDAR X) ))) ) )
|
||||
(POP MEMSTACK) ) )
|
||||
|
||||
(DEFUN ADVANCE (RULES)
|
||||
(RPLACA (CDAR RULES) (COND
|
||||
((NULL (CDAR (CDAR RULES)))
|
||||
(CDDAR RULES) )
|
||||
((CDAR (CDAR RULES))) )) )
|
||||
|
||||
(DEFUN RECONSTRUCT (RULE PARSLST WORD SENTENCE V1)
|
||||
(LOOP
|
||||
((NULL RULE)
|
||||
(REVERSE SENTENCE) )
|
||||
(SETQ WORD (CAR RULE))
|
||||
( ((NUMBERP WORD)
|
||||
(SETQ WORD (DOCNTH PARSLST WORD))
|
||||
(SETQ V1 (CAR WORD))
|
||||
(LOOP
|
||||
((EQ V1 (CADR WORD)))
|
||||
(PUSH (POP V1) SENTENCE) ) )
|
||||
(PUSH WORD SENTENCE) )
|
||||
(POP RULE) ) )
|
||||
|
||||
(DEFUN TEST (D S CD PSV)
|
||||
(SETQ PSV (CDR PARSLST))
|
||||
(LOOP
|
||||
((NULL D)
|
||||
((NOT S)
|
||||
(SETQ PARSLST (CAR PARSLST))
|
||||
T )
|
||||
(RN) )
|
||||
(SETQ CD (CAR D))
|
||||
((ZEROP CD)
|
||||
(TCONC PARSLST S)
|
||||
(POP D)
|
||||
((NULL D)
|
||||
(SETQ PARSLST (CAR PARSLST))
|
||||
T )
|
||||
(LOOP
|
||||
((TEST D S) T)
|
||||
(POP S)
|
||||
((NULL S)
|
||||
(RN) ) ) )
|
||||
((NOT (RNP))
|
||||
(RN) )
|
||||
(POP S)
|
||||
(POP D) ) )
|
||||
|
||||
(DEFUN RN ()
|
||||
(RPLACD PARSLST (COND
|
||||
((NOT PSV) NIL)
|
||||
((RPLACD PSV NIL)) )) NIL)
|
||||
|
||||
(DEFUN RNP ()
|
||||
((NULL S) NIL)
|
||||
((NUMBERP CD)
|
||||
(TCONC PARSLST S)
|
||||
(SETQ S (DOCNTH S CD)) )
|
||||
((COND
|
||||
((ATOM CD)
|
||||
(EQ CD (CAR S)) )
|
||||
((CAR CD)
|
||||
(MEMBER (CAR S) CD) )
|
||||
((TEST4 (CAR S) (CDR CD))) )
|
||||
(TCONC PARSLST S) T ) )
|
||||
|
||||
(DEFUN TEST4 (CS L)
|
||||
(LOOP
|
||||
((GETP CS (POP L)))
|
||||
((NULL L) NIL) ) )
|
||||
|
||||
(DEFUN BCONC (X Y)
|
||||
(SETQ X (CONS NIL X))
|
||||
((NULL Y)
|
||||
(CONS X X) )
|
||||
((NULL (CAR Y))
|
||||
(RPLACD Y X)
|
||||
(RPLACA Y X) )
|
||||
(RPLACA (CAR Y) X)
|
||||
(RPLACA Y (CAAR Y)) )
|
||||
|
||||
(DEFUN GETP (X Y)
|
||||
(LOOP
|
||||
(SETQ X (CDR X))
|
||||
((NULL X) NIL)
|
||||
((EQ (CAR X) Y)
|
||||
(CADR X) )
|
||||
(POP X) ) )
|
||||
|
||||
(DEFUN PUTP (X Y Z XX)
|
||||
(SETQ XX X)
|
||||
(LOOP
|
||||
((NULL (CDR X))
|
||||
(RPLACD X (LIST Y Z)) )
|
||||
((EQ (CADR X) Y)
|
||||
(RPLACA (CDDR X) Z) )
|
||||
(SETQ X (CDDR X))
|
||||
((NULL X)
|
||||
(RPLACD XX (LIST* Y Z (CDR XX))) ) )
|
||||
Z )
|
||||
|
||||
(SETQ XXXX 'XXXX)
|
||||
|
||||
(DEFUN SETNONE (A)
|
||||
(SETQ A XXXX)
|
||||
(RPLACD A (GETP 'NONE 'LASTRESORT))
|
||||
(PUTP 'NONE 'MEM (LIST 'RULES (LIST (LIST (LIST 0) (CONS) A))) ) )
|
||||
|
||||
(DEFUN DOCNTH (X Y)
|
||||
((ZEROP Y)
|
||||
(CONS NIL X) )
|
||||
(LOOP
|
||||
(DECQ Y)
|
||||
((ZEROP Y) X)
|
||||
(POP X) ) )
|
||||
|
||||
(DEFUN RPLQQ (NLAMBDA ARG
|
||||
(RPLACD (CAR ARG) (CDR ARG))
|
||||
(CAR ARG) ))
|
||||
|
||||
; * * * C O N S O L E I N T E R F A C E R O U T I N E S * * *
|
||||
|
||||
(DEFUN READSENT (SENTENCE
|
||||
WORD )
|
||||
(LOOP
|
||||
(SETQ WORD (STRING-UPCASE (RATOM)))
|
||||
((MEMBER WORD TRMLIS)
|
||||
(REVERSE SENTENCE) )
|
||||
( ((MEMBER WORD SEPLIS)
|
||||
(PUSH (PACK* (POP SENTENCE) WORD (STRING-UPCASE (RATOM))) SENTENCE) )
|
||||
(PUSH WORD SENTENCE) ) ) )
|
||||
|
||||
(DEFUN PRTSENT (SENTENCE
|
||||
WORD *PRINT-DOWNCASE* )
|
||||
(SETQ *PRINT-DOWNCASE* T)
|
||||
(PRTCAP (POP SENTENCE))
|
||||
(LOOP
|
||||
((NULL SENTENCE)
|
||||
(PRINC '?) )
|
||||
(SETQ WORD (POP SENTENCE))
|
||||
((MEMBER WORD TRMLIS)
|
||||
(PRINC WORD) )
|
||||
( ((OR (NULL SENTENCE) (MEMBER (CAR SENTENCE) TRMLIS)
|
||||
(MEMBER (CAR SENTENCE) PCTLIS) )
|
||||
(PRETERPRI WORD) ) )
|
||||
( ((MEMBER WORD PCTLIS))
|
||||
(SPACES 1) )
|
||||
( ((MEMBER WORD CAPLIS)
|
||||
(PRTCAP WORD) )
|
||||
(PRINC WORD) ) ) )
|
||||
|
||||
(DEFUN PRTCAP (WORD)
|
||||
((NUMBERP WORD)
|
||||
(PRINC WORD) )
|
||||
(PRETERPRI WORD)
|
||||
(SETQ WORD (UNPACK WORD))
|
||||
(SETQ *PRINT-DOWNCASE*) (PRINC (CAR WORD)) (SETQ *PRINT-DOWNCASE* T)
|
||||
(LOOP
|
||||
(POP WORD)
|
||||
((NULL WORD))
|
||||
(PRINC (CAR WORD)) ) )
|
||||
|
||||
(DEFUN PRETERPRI (WORD)
|
||||
((> (+ (SPACES) (LENGTH WORD)) (LINELENGTH))
|
||||
(TERPRI) ) )
|
||||
|
||||
(SETQ CAPLIS '(I HAWAII))
|
||||
(SETQ TRMLIS '("." ! ?))
|
||||
(SETQ PCTLIS '("," ";" "(" ")" ":"))
|
||||
(SETQ SEPLIS '("'" "-"))
|
||||
|
||||
|
||||
; The remainder of this file is the script for the DOCTOR program.
|
||||
|
||||
(RPLQQ NONE LASTRESORT (RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(I AM NOT SURE I UNDERSTAND YOU FULLY ".")
|
||||
(PLEASE GO ON ".")
|
||||
(WHAT DOES THAT SUGGEST TO YOU)
|
||||
(WHAT ELSE WOULD YOU LIKE TO DISCUSS)
|
||||
(WHY DO YOU SAY THAT JUST NOW) ) )))
|
||||
|
||||
(RPLQQ SORRY PRIORITY 2 RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(PLEASE "DON'T" APOLOGIZE ".")
|
||||
(APOLOGIES ARE NOT NECESSARY ".")
|
||||
(WHAT FEELINGS DO YOU HAVE WHEN YOU APOLOGIZE) ) ))
|
||||
|
||||
(RPLQQ DONT TRANSLATION "DON'T")
|
||||
|
||||
(RPLQQ CANT TRANSLATION "CAN'T")
|
||||
|
||||
(RPLQQ WONT TRANSLATION "WON'T")
|
||||
|
||||
(RPLQQ REMEMBER PRIORITY 5 RULES (
|
||||
((REMEMBER 0)
|
||||
(NIL)
|
||||
(PRE (DO I REMEMBER 2) REMEMBER) )
|
||||
((YOU REMEMBER 0)
|
||||
(NIL)
|
||||
(DO YOU OFTEN THINK OF 3)
|
||||
(WHAT ELSE DOES THINKING OF 3 BRING TO MIND)
|
||||
(WHAT ELSE DO YOU REMEMBER)
|
||||
(WHY DO YOU REMEMBER 3 JUST NOW)
|
||||
(WHAT IN THE PRESENT SITUATION REMINDS YOU OF 3)
|
||||
(WHAT IS THE CONNECTION BETWEEN ME AND 3) )
|
||||
((DO I REMEMBER 0)
|
||||
(NIL)
|
||||
(WHY DID YOU THINK I WOULD FORGET 4)
|
||||
(WHY DO YOU THINK I SHOULD RECALL 4 NOW)
|
||||
(WHAT ABOUT 4)
|
||||
WHAT
|
||||
(YOU MENTIONED 4) )
|
||||
((0)
|
||||
(NIL)
|
||||
NEWKEY ) ))
|
||||
|
||||
(RPLQQ IF PRIORITY 3 RULES (
|
||||
((0 IF 0 HAD 0)
|
||||
(NIL)
|
||||
(PRE (1 2 3 MIGHT HAVE 5) IF) )
|
||||
((0 IF 0)
|
||||
(NIL)
|
||||
(DO YOU THINK ITS LIKELY THAT 3)
|
||||
(DO YOU WISH THAT 3)
|
||||
(WHAT DO YOU THINK ABOUT 3)
|
||||
("REALLY," IF 3) ) ))
|
||||
|
||||
(RPLQQ DREAMT PRIORITY 4 RULES (
|
||||
((0 YOU DREAMT 0)
|
||||
(NIL)
|
||||
(REALLY 4)
|
||||
(HAVE YOU EVER FANTASIZED 4 WHILE YOU WERE AWAKE)
|
||||
(HAVE YOU DREAMT 4 BEFORE)
|
||||
DREAM
|
||||
NEWKEY)
|
||||
((0) (NIL) DREAM NEWKEY) ))
|
||||
|
||||
(RPLQQ DREAMED TRANSLATION DREAMT PRIORITY 4 RULES (DREAMT))
|
||||
|
||||
(RPLQQ DREAM PRIORITY 3 RULES (
|
||||
((0 YOU DREAM (OF ABOUT) 0)
|
||||
(NIL)
|
||||
(WHAT MIGHT 5 REPRESENT)
|
||||
(WHAT DOES 5 SUGGEST TO YOU)
|
||||
(HOW DOES THAT DREAM RELATE TO YOUR PROBLEM) )
|
||||
((0)
|
||||
(NIL)
|
||||
(WHAT DOES THAT DREAM SUGGEST TO YOU)
|
||||
(WHAT DO YOU DREAM ABOUT)
|
||||
(WHAT PERSONS APPEAR IN YOUR DREAMS)
|
||||
(WOULD YOU LIKE TO FLEE FROM REALITY)
|
||||
NEWKEY ) ))
|
||||
|
||||
(RPLQQ DREAMS TRANSLATION DREAM PRIORITY 3 RULES (DREAM))
|
||||
|
||||
(RPLQQ HOW RULES (WHAT) PRIORITY 0)
|
||||
|
||||
(RPLQQ WHEN PRIORITY 0 RULES (
|
||||
((WHEN (DO DID DOES WILL) 0)
|
||||
(NIL)
|
||||
XXWHAT )
|
||||
((0)
|
||||
(NIL)
|
||||
(IS THERE ANY OTHER TIME)
|
||||
(WHY "THEN," DO YOU SUPPOSE) ) ))
|
||||
|
||||
(RPLQQ ALIKE PRIORITY 10 RULES (DIT))
|
||||
|
||||
(RPLQQ SAME PRIORITY 3 RULES (DIT))
|
||||
|
||||
(RPLQQ CERTAINLY PRIORITY 0 RULES (YES))
|
||||
|
||||
(RPLQQ FEEL BELIEF T)
|
||||
|
||||
(RPLQQ THINK BELIEF T)
|
||||
|
||||
(RPLQQ BELIEVE BELIEF T)
|
||||
|
||||
(RPLQQ WISH BELIEF T)
|
||||
|
||||
(RPLQQ BET BELIEF T)
|
||||
|
||||
(RPLQQ MY MEMR (
|
||||
((YOUR 2 0)
|
||||
(NIL)
|
||||
("LET'S" DISCUSS FURTHER WHY YOUR 2 3 ".")
|
||||
(EARLIER YOU SAID YOUR 2 3 ".")
|
||||
(BUT YOUR 2 3 ".")
|
||||
(DOES THAT HAVE ANYTHING TO DO WITH THE FACT THAT YOUR 2 3) )
|
||||
((0 YOUR 1 0)
|
||||
(NIL)
|
||||
(EARLIER YOU SAID YOUR 3 4)
|
||||
(BUT YOUR 3 4)
|
||||
(DOES THAT HAVE ANYTHING TO DO WITH YOUR 3 4) )
|
||||
((0 YOUR 1)
|
||||
(NIL)
|
||||
(WOULD YOU LIKE TO DISCUSS YOUR 3)
|
||||
(PERHAPS THAT CONCERNS YOUR 3 ".")
|
||||
(TELL ME MORE ABOUT YOUR 3 ".") ) )
|
||||
|
||||
PRIORITY 0 TRANSLATION YOUR RULES (
|
||||
((0 YOUR 0 (NIL FAMILY) 0)
|
||||
(NIL)
|
||||
(TELL ME MORE ABOUT YOUR FAMILY ".")
|
||||
(WHO ELSE IN YOUR FAMILY 5)
|
||||
(YOUR 4)
|
||||
(WHAT ELSE COMES TO MIND WHEN YOU THINK OF YOUR 4) )
|
||||
((YOUR 2 0)
|
||||
(NIL)
|
||||
(IS IT IMPORTANT TO YOU THAT YOUR 2 3)
|
||||
(DO YOU SUPPOSE ANYONE "ELSE'S" 2 3)
|
||||
(WHAT MAKES YOU THINK YOUR 2 3)
|
||||
(SUPPOSE I "DIDN'T" BELIEVE THAT YOUR 2 3 ".") )
|
||||
((0 YOUR 1)
|
||||
(NIL)
|
||||
(YOUR 3)
|
||||
(WHY DO YOU SAY YOUR 3)
|
||||
(WHO ELSE KNOWS ABOUT YOUR 3)
|
||||
(WHY DO YOU MENTION YOUR 3 JUST NOW)
|
||||
(WHY IS YOUR 3 IMPORTANT TO YOU)
|
||||
(DO YOU OFTEN DISCUSS YOUR 3) ) ))
|
||||
|
||||
(RPLQQ PERHAPS PRIORITY 0 RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(YOU "DON'T" SEEM QUITE CERTAIN ".")
|
||||
(WHY THE UNCERTAIN TONE)
|
||||
("CAN'T" YOU BE MORE POSITIVE)
|
||||
(YOU "AREN'T" SURE)
|
||||
("DON'T" YOU KNOW) ) ))
|
||||
|
||||
(RPLQQ MAYBE PRIORITY 0 RULES (PERHAPS))
|
||||
|
||||
(RPLQQ NAME PRIORITY 15 RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(I AM NOT INTERESTED IN NAMES ".")
|
||||
("I'VE" TOLD YOU BEFORE I "DON'T" CARE ABOUT
|
||||
NAMES - PLEASE CONTINUE ".") ) ))
|
||||
|
||||
(RPLQQ DEUTSCH PRIORITY 0 RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(I AM "SORRY," I SPEAK ONLY ENGLISH) ) ))
|
||||
|
||||
(RPLQQ FRANCAIS PRIORITY 0 RULES (DEUTSCH))
|
||||
|
||||
(RPLQQ SVENSKA PRIORITY 0 RULES (DEUTSCH))
|
||||
|
||||
(RPLQQ ITALIANO PRIORITY 0 RULES (DEUTSCH))
|
||||
|
||||
(RPLQQ ESPANOL PRIORITY 0 RULES (DEUTSCH))
|
||||
|
||||
(RPLQQ HELLO PRIORITY 0 RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
("HI," HOW ARE YOU) ) ))
|
||||
|
||||
(RPLQQ COMPUTER PRIORITY 8 RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(DO COMPUTERS WORRY YOU)
|
||||
(WHY DO YOU MENTION COMPUTERS)
|
||||
(WHAT DO YOU THINK MACHINES HAVE TO DO WITH YOUR PROBLEM)
|
||||
("DON'T" YOU THINK COMPUTERS CAN HELP PEOPLE) ) ))
|
||||
|
||||
(RPLQQ MACHINE PRIORITY 8 RULES (COMPUTER))
|
||||
|
||||
(RPLQQ MACHINES PRIORITY 8 RULES (COMPUTER))
|
||||
|
||||
(RPLQQ COMPUTERS PRIORITY 10 RULES (COMPUTER))
|
||||
|
||||
(RPLQQ AM PRIORITY 0 TRANSLATION ARE RULES (
|
||||
((ARE YOU 0)
|
||||
(NIL)
|
||||
(DO YOU BELIEVE YOU ARE 3)
|
||||
(WOULD YOU WANT TO BE 3)
|
||||
(YOU WISH I WOULD TELL YOU YOU ARE 3 ".")
|
||||
(WHAT WOULD IT MEAN IF YOU WERE 3)
|
||||
XXWHAT )
|
||||
((0)
|
||||
(NIL)
|
||||
(WHY DO YOU SAY "'AM'")
|
||||
(I "DON'T" UNDERSTAND THAT) ) ))
|
||||
|
||||
(RPLQQ ARE PRIORITY 0 RULES (
|
||||
((THERE (ARE IS) (NO NOT) 0)
|
||||
(NIL)
|
||||
(WHAT IF THERE WERE 4)
|
||||
(DID YOU THINK THERE MIGHT BE 4)
|
||||
(PRE (THERE 2 4) ARE) )
|
||||
((THERE (ARE IS) 0)
|
||||
(NIL)
|
||||
(2 THERE REALLY 3)
|
||||
(WHY 2 THERE 3)
|
||||
(HOW 3 THE 4 RELATED TO YOU) )
|
||||
((ARE I 0)
|
||||
(NIL)
|
||||
(WHY ARE YOU INTERESTED IN WHETHER I AM 3 OR NOT)
|
||||
(WOULD YOU PREFER IF I "WEREN'T" 3)
|
||||
(PERHAPS I AM 3 IN YOUR FANTASIES ".")
|
||||
(DO YOU SOMETIMES THINK I AM 3)
|
||||
XXWHAT )
|
||||
((ARE 0)
|
||||
(NIL)
|
||||
XXWHAT )
|
||||
((0 1 (ARE IS) NOT 0)
|
||||
(NIL)
|
||||
(POSSIBLY THAT IS FOR THE BETTER ".")
|
||||
(WHAT IF 2 WERE 5)
|
||||
(WHAT DO YOU REALLY KNOW ABOUT 2))
|
||||
((0 (ARE IS) 0)
|
||||
(NIL)
|
||||
(SUPPOSE 1 WERE NOT 3 ".")
|
||||
(POSSIBLY 1 REALLY 2 NOT 3 ".")
|
||||
(TELL ME MORE ABOUT 1 ".")
|
||||
(DID YOU THINK 1 MIGHT NOT BE 3)
|
||||
(1 PERHAPS 2 3 ".") ) ))
|
||||
|
||||
(RPLQQ YOUR PRIORITY 0 TRANSLATION MY RULES (
|
||||
((0 MY 1)
|
||||
(NIL)
|
||||
(WHY ARE YOU CONCERNED OVER MY 3)
|
||||
(WHAT ABOUT YOUR OWN 3)
|
||||
(ARE YOU WORRIED ABOUT SOMEONE "ELSE'S" 3)
|
||||
("REALLY," MY 3))
|
||||
((MY 0)
|
||||
(NIL)
|
||||
(PERHAPS YOUR OWN 2 ".")
|
||||
(ARE YOU WORRIED THAT MY 2) ) ))
|
||||
|
||||
(RPLQQ WAS PRIORITY 2 RULES (
|
||||
((WAS YOU 0)
|
||||
(NIL)
|
||||
(WHAT IF YOU WERE 3)
|
||||
(DO YOU THINK YOU WERE 3)
|
||||
(WERE YOU 3)
|
||||
(WHAT WOULD IT MEAN IF YOU WERE 3)
|
||||
XXWHAT)
|
||||
((YOU WAS 0)
|
||||
(NIL)
|
||||
(WERE YOU REALLY)
|
||||
(WHY DO YOU TELL ME YOU WERE 3 NOW)
|
||||
(PERHAPS I ALREADY KNEW YOU WERE 3 "."))
|
||||
((WAS I 0)
|
||||
(NIL)
|
||||
(WOULD YOU LIKE TO BELIEVE I WAS 3)
|
||||
(WHAT SUGGESTS THAT I WAS 3)
|
||||
(WHAT DO YOU THINK)
|
||||
(PERHAPS I WAS 3 ".")
|
||||
(WHAT IF I HAD BEEN 3) ) ))
|
||||
|
||||
(RPLQQ WERE PRIORITY 0 TRANSLATION WAS RULES (WAS))
|
||||
|
||||
(RPLQQ ME TRANSLATION YOU)
|
||||
|
||||
(RPLQQ "YOU'RE" PRIORITY 0 TRANSLATION "I'M" RULES (
|
||||
((0 "I'M" 0)
|
||||
(NIL)
|
||||
(PRE (I ARE 3) YOU) ) ))
|
||||
|
||||
(RPLQQ "I'M" PRIORITY 0 TRANSLATION "YOU'RE" RULES (
|
||||
((0 "YOU'RE" 0)
|
||||
(NIL)
|
||||
(PRE (YOU ARE 3) I) ) ))
|
||||
|
||||
(RPLQQ MYSELF TRANSLATION YOURSELF)
|
||||
|
||||
(RPLQQ YOURSELF TRANSLATION MYSELF)
|
||||
|
||||
(RPLQQ MOTHER FAMILY T)
|
||||
|
||||
(RPLQQ MOM TRANSLATION MOTHER FAMILY T)
|
||||
|
||||
(RPLQQ DAD TRANSLATION FATHER FAMILY T)
|
||||
|
||||
(RPLQQ FATHER FAMILY T)
|
||||
|
||||
(RPLQQ SISTER FAMILY T)
|
||||
|
||||
(RPLQQ BROTHER FAMILY T)
|
||||
|
||||
(RPLQQ WIFE FAMILY T)
|
||||
|
||||
(RPLQQ CHILDREN FAMILY T)
|
||||
|
||||
(RPLQQ I PRIORITY 0 TRANSLATION YOU RULES (
|
||||
((0 YOU (WANT NEED) 0)
|
||||
(NIL)
|
||||
(WHAT WOULD IT MEAN TO YOU IF YOU GOT 4)
|
||||
(WHY DO YOU WANT 4)
|
||||
(WHAT WOULD GETTING 4 MEAN TO YOU))
|
||||
((0 YOU ARE 0 (SAD UNHAPPY DEPRESSED SICK ILL) 0)
|
||||
(NIL)
|
||||
(I AM SORRY TO HEAR YOU ARE 5 ".")
|
||||
(DO YOU THINK COMING HERE WILL HELP YOU NOT TO BE 5)
|
||||
(CAN YOU EXPLAIN WHAT MADE YOU 5))
|
||||
((0 YOU ARE 0 (HAPPY ELATED GLAD BETTER) 0)
|
||||
(NIL)
|
||||
(HOW HAVE I HELPED YOU TO BE 5)
|
||||
(HAS YOUR TREATMENT MADE YOU 5)
|
||||
(WHAT MAKES YOU 5 JUST NOW))
|
||||
((0 YOU (NIL BELIEF) YOU 0)
|
||||
(NIL)
|
||||
(DO YOU REALLY THINK SO)
|
||||
(BUT YOU ARE NOT SURE YOU 5)
|
||||
(DO YOU REALLY DOUBT YOU 5))
|
||||
((0 YOU 0 (NIL BELIEF) 0 I 0)
|
||||
(NIL)
|
||||
(PRE (6 7) YOU))
|
||||
((0 YOU ARE 0)
|
||||
(NIL)
|
||||
(IS IT BECAUSE YOU ARE 4 THAT YOU CAME TO ME)
|
||||
(HOW LONG HAVE YOU BEEN 4)
|
||||
(DO YOU BELIEVE IT NORMAL TO BE 4)
|
||||
(DO YOU ENJOY BEING 4))
|
||||
((0 YOU ("CAN'T" CANNOT) 0)
|
||||
(NIL)
|
||||
(HOW DO YOU KNOW YOU "CAN'T" 4)
|
||||
(HAVE YOU TRIED)
|
||||
(PERHAPS YOU COULD 4 NOW ".")
|
||||
(DO YOU REALLY WANT TO BE ABLE TO 4))
|
||||
((0 YOU ("DON'T" "WON'T") 0)
|
||||
(NIL)
|
||||
("DON'T" YOU REALLY 4)
|
||||
(WHY "DON'T" YOU 4)
|
||||
(DO YOU WISH YOU DID 4)
|
||||
(DOES THAT TROUBLE YOU))
|
||||
((0 YOU FEEL 0)
|
||||
(NIL)
|
||||
(TELL ME MORE ABOUT SUCH FEELINGS ".")
|
||||
(DO YOU OFTEN FEEL 4)
|
||||
(DO YOU ENJOY FEELING 4)
|
||||
(OF WHAT DOES FEELING 4 REMIND YOU))
|
||||
((YOU 0 I)
|
||||
(NIL)
|
||||
(PERHAPS IN YOUR FANTASY WE 2 EACH OTHER ".")
|
||||
(DO YOU WISH TO 2 ME)
|
||||
(YOU SEEM TO NEED TO 2 ME ".")
|
||||
(DO YOU 2 ANYONE ELSE))
|
||||
((0 YOU (NIL EMOTION) 0)
|
||||
(NIL)
|
||||
(WHAT ELSE DO YOU 3)
|
||||
(TELL ME MORE ABOUT 4 ".")
|
||||
(WHY DO YOU 3 4)
|
||||
(I DOUBT THAT YOU REALLY 3 4 "."))
|
||||
((0 YOU 1 0)
|
||||
(NIL)
|
||||
(YOU SAY 2 3 4)
|
||||
(CAN YOU ELABORATE ON THAT)
|
||||
(DO YOU SAY 2 3 4 FOR SOME SPECIAL REASON)
|
||||
(TELL ME MORE ABOUT YOURSELF ".")
|
||||
(OH? 2 3 4)
|
||||
("THAT'S" QUITE INTERESTING ".")))
|
||||
MEMR (
|
||||
((0 YOU ARE 0)
|
||||
(NIL)
|
||||
(ARE YOU STILL 4)
|
||||
(EARLIER YOU SAID YOU WERE 4 ".")
|
||||
(MAYBE NOW WE CAN DISCUSS WHY YOU ARE 4 ".")
|
||||
(DID YOU TELL ME YOU WERE 4))))
|
||||
|
||||
(RPLQQ YOU PRIORITY 0 TRANSLATION I RULES (
|
||||
((0 I REMIND YOU OF 0)
|
||||
(NIL)
|
||||
DIT)
|
||||
((0 I ARE 0)
|
||||
(NIL)
|
||||
(WHAT MAKES YOU THINK I AM 4)
|
||||
(DOES IT PLEASE YOU TO BELIEVE I AM 4)
|
||||
(PERHAPS YOU WOULD LIKE TO BE 4 ".")
|
||||
(DO YOU SOMETIMES WISH YOU WERE 4))
|
||||
((0 I 0 YOU)
|
||||
(NIL)
|
||||
(WHY DO YOU THINK I 3 YOU)
|
||||
(YOU LIKE TO THINK I 3 YOU - "DON'T" YOU)
|
||||
(WHAT MAKES YOU THINK I 3 YOU)
|
||||
(REALLY? I 3 YOU)
|
||||
(DO YOU WISH TO BELIEVE I 3 YOU)
|
||||
(SUPPOSE I DID 3 YOU - WHAT WOULD THAT MEAN)
|
||||
(DOES SOMEONE ELSE BELIEVE I 3 YOU))
|
||||
((0 I 1 0)
|
||||
(NIL)
|
||||
(SUPPOSE YOU 3 4 ".")
|
||||
(OH? I 3 4)
|
||||
(WHAT MAKES YOU THINK I 3 4)
|
||||
(WHO ARE YOU REALLY TALKING ABOUT))))
|
||||
|
||||
(RPLQQ XXYYZZ RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(IS THERE SOMETHING BOTHERING YOU)
|
||||
(CAN YOU BE MORE INFORMATIVE)
|
||||
(PERHAPS YOU WOULD RATHER TALK ABOUT SOMETHING ELSE ".")
|
||||
(PLEASE TELL ME MORE "."))))
|
||||
|
||||
(RPLQQ YES PRIORITY -1 RULES (
|
||||
((0) (NIL)
|
||||
XXYYZZ
|
||||
(WHY ARE YOU SO SURE)
|
||||
(I SEE ".")
|
||||
(I UNDERSTAND "."))))
|
||||
|
||||
(RPLQQ NO PRIORITY -1 RULES (
|
||||
((0 NO (BODY ONE) 0)
|
||||
(NIL)
|
||||
NOBODY)
|
||||
((0)
|
||||
(NIL)
|
||||
XXYYZZ
|
||||
(VERY WELL ".")
|
||||
(WHY NOT)
|
||||
(WHY "'NO'") NEWKEY)))
|
||||
|
||||
(RPLQQ CAN PRIORITY 0 RULES (
|
||||
((CAN I 0)
|
||||
(NIL)
|
||||
(YOU BELIEVE I CAN 3 "DON'T" YOU)
|
||||
XXWHAT
|
||||
(YOU WANT ME TO BE ABLE TO 3 ".")
|
||||
(PERHAPS YOU WOULD LIKE TO BE ABLE TO 3 YOURSELF "."))
|
||||
((CAN YOU 0)
|
||||
(NIL)
|
||||
(WHETHER OR NOT YOU CAN 3 DEPENDS ON YOU MORE THAN ON ME ".")
|
||||
(DO YOU WANT TO BE ABLE TO 3)
|
||||
(PERHAPS YOU "DON'T" WANT TO 3 ".")
|
||||
XXWHAT)))
|
||||
|
||||
(RPLQQ IS PRIORITY 0 RULES (
|
||||
((IS 0)
|
||||
(NIL)
|
||||
XXWHAT )
|
||||
ARE ))
|
||||
|
||||
(RPLQQ WHERE PRIORITY 0 RULES (WHAT))
|
||||
|
||||
(RPLQQ WHAT PRIORITY 0 RULES (
|
||||
(((HOW WHERE WHAT WHY) 0)
|
||||
(NIL)
|
||||
XXWHAT)))
|
||||
|
||||
(RPLQQ XXWHAT RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(WHY DO YOU ASK)
|
||||
(WHY DOES THAT QUESTION INTEREST YOU)
|
||||
(WHY ARE SUCH QUESTIONS ON YOUR MIND)
|
||||
(WHAT ANSWER WOULD PLEASE YOU MOST)
|
||||
(WHAT DO YOU THINK)
|
||||
(WHEN HAVE YOU ASKED SUCH QUESTIONS BEFORE)
|
||||
(WHO ELSE HAVE YOU ASKED))))
|
||||
|
||||
(RPLQQ BECAUSE PRIORITY 0 RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(IS THAT THE REAL REASON)
|
||||
(I SEE ".")
|
||||
("DON'T" ANY OTHER REASONS COME TO MIND)
|
||||
(DOES THAT REASON SEEM TO EXPLAIN ANYTHING ELSE)
|
||||
(AND WHAT DOES THAT SUGGEST)
|
||||
(WHAT OTHER REASONS MIGHT THERE BE))))
|
||||
|
||||
(RPLQQ WHY PRIORITY 0 RULES (
|
||||
((0 WHY ("DON'T" "WON'T") I 0)
|
||||
(NIL)
|
||||
(DO YOU BELIEVE I "DON'T" 5)
|
||||
(PERHAPS I WILL 5 IN GOOD TIME ".")
|
||||
(SHOULD YOU 5 YOURSELF)
|
||||
(YOU WANT ME TO 5 ".")
|
||||
WHAT)
|
||||
((0 WHY "CAN'T" YOU 0)
|
||||
(NIL)
|
||||
(DO YOU THINK YOU SHOULD BE ABLE TO 5)
|
||||
(DO YOU WANT TO BE ABLE TO 5)
|
||||
(DO YOU BELIEVE THIS WILL HELP YOU TO 5)
|
||||
(HAVE YOU ANY IDEA WHY YOU "CAN'T" 5)
|
||||
WHAT )
|
||||
WHAT))
|
||||
|
||||
(RPLQQ EVERYONE PRIORITY 2 RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(CAN YOU THINK OF ANYONE IN PARTICULAR)
|
||||
("WHO," FOR EXAMPLE)
|
||||
(YOU ARE THINKING OF A VERY SPECIAL PERSON ".")
|
||||
(YOU HAVE A PARTICULAR PERSON IN "MIND," "DON'T" YOU) ) ))
|
||||
|
||||
(RPLQQ EVERYBODY PRIORITY 2 RULES (EVERYONE))
|
||||
|
||||
(RPLQQ NOBODY PRIORITY 2 RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(SURELY "SOMEONE...")
|
||||
(PERHAPS YOU JUST "DON'T" KNOW OF ANYONE "."))))
|
||||
|
||||
(RPLQQ NO-ONE PRIORITY 2 RULES (NOBODY))
|
||||
|
||||
(RPLQQ ALWAYS PRIORITY 1 RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(CAN YOU THINK OF A SPECIFIC EXAMPLE)
|
||||
(WHEN)
|
||||
(WHAT INCIDENT ARE YOU THINKING OF)
|
||||
("REALLY," ALWAYS) ) ))
|
||||
|
||||
(RPLQQ LIKE RULES (
|
||||
((0 (AM IS ARE WAS) 0 LIKE 0)
|
||||
(NIL)
|
||||
DIT) )
|
||||
EMOTION T PRIORITY 3)
|
||||
|
||||
(RPLQQ DIT RULES (
|
||||
((0)
|
||||
(NIL)
|
||||
(IN WHAT WAY)
|
||||
(WHAT RESEMBLANCE DO YOU SEE)
|
||||
(WHAT DOES THAT SIMILARITY SUGGEST TO YOU)
|
||||
(WHAT OTHER CONNECTIONS DO YOU SEE)
|
||||
(WHAT IS THE "CONNECTION," DO YOU SUPPOSE)
|
||||
(HOW) ) ))
|
||||
|
||||
(RPLQQ OH PRIORITY 10 RULES (
|
||||
((0 YOUR OH YOUR 0)
|
||||
(NIL)
|
||||
(PRE (1 MY-OH-MY 5) NEWKEY) )
|
||||
((0 OH YOUR 0)
|
||||
(NIL)
|
||||
(PRE (1 OH-MY 4) NEWKEY) ) ))
|
||||
|
||||
(RPLQQ EVERY PRIORITY 0 RULES (
|
||||
((0 EVERY (ONE BODY) 0)
|
||||
(NIL)
|
||||
EVERYONE )
|
||||
((0 EVERY TIME 0)
|
||||
(NIL)
|
||||
ALWAYS ) ))
|
||||
|
||||
(RPLQQ DO PRIORITY 0 RULES (
|
||||
((DO I 0)
|
||||
(NIL)
|
||||
(PRE (I 3) YOU)
|
||||
XXWHAT)
|
||||
((DO YOU 0)
|
||||
(NIL)
|
||||
(PRE (YOU 3) I)
|
||||
XXWHAT) ))
|
||||
|
||||
(RPLQQ GIRLS PRIORITY 3 RULES (
|
||||
((0 (GIRLS WOMEN) 0)
|
||||
(NIL)
|
||||
(PRE (1 2 S 3) BOY) ) ))
|
||||
|
||||
(RPLQQ WOMEN PRIORITY 3 RULES (GIRLS))
|
||||
|
||||
(RPLQQ BOY PRIORITY 3 PERSON T RULES (
|
||||
((0 (NIL PERSON) FRIEND 0)
|
||||
(NIL)
|
||||
(I WOULD LIKE TO MEET YOUR 2 FRIEND ".")
|
||||
(PRE (1 FRIEND 4) FRIEND)
|
||||
(SUPPOSE THE FRIEND WERE NOT A 2 "."))
|
||||
((0 (NIL PERSON) 0)
|
||||
(NIL)
|
||||
(WHY DO YOU SAY A 2)
|
||||
(WHAT 2 ARE YOU THINKING OF)
|
||||
NEWKEY)
|
||||
((0 (NIL PERSON) S 0)
|
||||
(NIL)
|
||||
(WHAT GROUP OF 2 ARE YOU THINKING OF)
|
||||
(I EXPECTED THAT YOU WOULD WANT TO TALK ABOUT 2 ".")
|
||||
(DO YOU KNOW MANY 2))))
|
||||
|
||||
(RPLQQ GIRL PRIORITY 3 PERSON T RULES (BOY))
|
||||
|
||||
(RPLQQ MAN PRIORITY 3 PERSON T RULES (BOY))
|
||||
|
||||
(RPLQQ WOMEN PRIORITY 3 PERSON T RULES (BOY))
|
||||
|
||||
(RPLQQ SEXY PRIORITY 5 RULES (SEX))
|
||||
|
||||
(RPLQQ SEXUAL PRIORITY 5 RULES (SEX))
|
||||
|
||||
(RPLQQ SEX PRIORITY 5 RULES (
|
||||
((0 YOU 0 SEX 0)
|
||||
(NIL)
|
||||
(ARE YOU SURE YOU REALLY 3 IT 5)
|
||||
(DO YOU REALLY WANT TO DISCUSS SEX)
|
||||
(PERHAPS YOU ARE WORRIED THAT YOU 3 IT 5)
|
||||
NEWKEY)
|
||||
((0)
|
||||
(NIL)
|
||||
(WHAT ARE YOUR REAL FEELINGS ABOUT SEX)
|
||||
(DO YOU EVER DREAM ABOUT SEX)
|
||||
(WHY DO YOU MENTION SEX)
|
||||
(COULD SEX BE PART OF YOUR PROBLEM)
|
||||
NEWKEY))
|
||||
MEMR (
|
||||
((0 YOU 0 SEX 0)
|
||||
(NIL)
|
||||
(EARLIER YOU SAID YOU 3 4 5 ".")
|
||||
(TELL ME AGAIN WHY YOU 3 4 5 ".")
|
||||
(DO YOU SAY THAT BECAUSE YOU 3 4 5))))
|
||||
|
||||
(RPLQQ FRIENDLY PRIORITY 0 RULES (FRIEND))
|
||||
|
||||
(RPLQQ FRIEND PRIORITY 1 RULES (
|
||||
((0 YOUR FRIEND 0)
|
||||
(NIL)
|
||||
(WHAT ELSE CAN YOU TELL ME ABOUT YOUR FRIEND)
|
||||
(WHAT MIGHT YOUR FRIENDS HAVE TO DO WITH YOUR PROBLEM))
|
||||
((0)
|
||||
(NIL)
|
||||
(DO YOU THINK FRIENDS ARE IMPORTANT)
|
||||
(WHAT DO YOU THINK ABOUT YOUR FRIENDS))))
|
||||
|
||||
(RPLQQ CRY PRIORITY 2 RULES (LAUGH))
|
||||
|
||||
(RPLQQ LAUGH PRIORITY 2 RULES (
|
||||
((0 (LAUGH CRY) 0)
|
||||
(NIL)
|
||||
(WHAT WOULD MAKE YOU 2)
|
||||
(REALLY 2)
|
||||
(WOULD YOU LIKE TO LAUGH)
|
||||
NEWKEY)))
|
||||
|
||||
(RPLQQ LOVE EMOTION T)
|
||||
|
||||
(RPLQQ HATE EMOTION T)
|
||||
|
||||
(RPLQQ DISLIKE EMOTION NIL)
|
||||
|
||||
(DOCTOR (RDS))
|
||||
|
||||
48
Microsoft muLISP-86 v51/E.LSP
Normal file
48
Microsoft muLISP-86 v51/E.LSP
Normal file
@ -0,0 +1,48 @@
|
||||
; Compute e to 192 digits
|
||||
|
||||
(setq digits 200)
|
||||
(setq high digits)
|
||||
(setq count 0)
|
||||
(setq x 0)
|
||||
(setq n (- high 1))
|
||||
|
||||
(defmacro m-ignore (fun &body body)
|
||||
"ignores the return value of a function"
|
||||
`(progn (,fun ,@body)
|
||||
(values)))
|
||||
|
||||
(defun rune() (prog ()
|
||||
_nextn_
|
||||
(setf (aref a n) 1)
|
||||
(cond ((plusp n)
|
||||
(setq n (sub1 n))
|
||||
(go _nextn_))
|
||||
)
|
||||
|
||||
(setf (aref a 1) 2)
|
||||
(setf (aref a 0) 0)
|
||||
|
||||
_nexthigh_
|
||||
(setq high (sub1 high))
|
||||
(setq n high)
|
||||
_nextn2_
|
||||
(setf (aref a n) (mod x n))
|
||||
(setq x (+ (* 10 (aref a (sub1 n))) (truncate (/ x n))))
|
||||
(cond ((> n 1)
|
||||
(setq n (sub1 n))
|
||||
(go _nextn2_))
|
||||
)
|
||||
(princ x)
|
||||
(cond ((> high 9)
|
||||
(go _nexthigh_))
|
||||
)
|
||||
(return "")
|
||||
))
|
||||
|
||||
(setq a (make-array digits :initial-element 0 ))
|
||||
(setq startTime (time))
|
||||
(clear-screen)
|
||||
(rune)
|
||||
(princ "elapsed hundredths of a second: ") (- (time) startTime) (TERPRI)
|
||||
|
||||
(system)
|
||||
1733
Microsoft muLISP-86 v51/EDIT.LSP
Normal file
1733
Microsoft muLISP-86 v51/EDIT.LSP
Normal file
File diff suppressed because it is too large
Load Diff
261
Microsoft muLISP-86 v51/EIGHTS.LSP
Normal file
261
Microsoft muLISP-86 v51/EIGHTS.LSP
Normal file
@ -0,0 +1,261 @@
|
||||
; File EIGHTS.LSP (C) 12/29/85 Soft WareHouse, Inc.
|
||||
|
||||
|
||||
; T h e E I G H T S P u z z l e
|
||||
|
||||
; EIGHTS searches for the next node using an Ordered State-space
|
||||
; search as described in "Principles of Artificial Intelligence", by
|
||||
; Nils J. Nilsson, 1980, Tioga Publishing Co., Palo Alto, CA; Pgs 85-88.
|
||||
; Program originally written by Mr. Peter A. Harada of Honolulu, Hawaii.
|
||||
|
||||
(LOOP (PRINC '*) (EVAL (READ)) ((NULL RDS)) )
|
||||
|
||||
(DEFUN EIGHTS (
|
||||
LEGAL-LST RSLT-LST CENTER-COLUMN CHAR)
|
||||
(LOOP
|
||||
(CLEAR-SCREEN) (TERPRI)
|
||||
(CENTER "* * * T h e E I G H T S P u z z l e * * *")
|
||||
(TERPRI 2)
|
||||
(WRITE-STRING "Enter in random order the digits 1 through 8 and a space:")
|
||||
(SETQ CENTER-COLUMN (TRUNCATE (CADDDR (MAKE-WINDOW)) 2))
|
||||
(SET-CURSOR 6 (- CENTER-COLUMN 8)) (WRITE-STRING " ----------- ")
|
||||
(SET-CURSOR 7 (- CENTER-COLUMN 8)) (WRITE-STRING "| | | |")
|
||||
(SET-CURSOR 8 (- CENTER-COLUMN 8)) (WRITE-STRING "|---+---+---|")
|
||||
(SET-CURSOR 9 (- CENTER-COLUMN 8)) (WRITE-STRING "| | | |")
|
||||
(SET-CURSOR 10 (- CENTER-COLUMN 8)) (WRITE-STRING "|---+---+---|")
|
||||
(SET-CURSOR 11 (- CENTER-COLUMN 8)) (WRITE-STRING "| | | |")
|
||||
(SET-CURSOR 12 (- CENTER-COLUMN 8)) (WRITE-STRING " ----------- ")
|
||||
(SETQ LEGAL-LST (LIST 1 2 3 4 5 6 7 8 " "))
|
||||
(SETQ RSLT-LST (LIST NIL NIL NIL NIL NIL NIL NIL NIL NIL))
|
||||
(READ-ROW 7 (- CENTER-COLUMN 6) '(0 1 2))
|
||||
(READ-ROW 9 (- CENTER-COLUMN 6) '(7 8 3))
|
||||
(READ-ROW 11 (- CENTER-COLUMN 6) '(6 5))
|
||||
(SET-CURSOR 11 (+ CENTER-COLUMN 2))
|
||||
(SETQ CHAR (CAR LEGAL-LST))
|
||||
( ((EQ (PRINC CHAR) '" ")
|
||||
(SETQ CHAR 9) ) )
|
||||
(TERPRI 3)
|
||||
(RPLACA (NTHCDR 4 RSLT-LST) CHAR)
|
||||
(EIGHTS-AUX RSLT-LST)
|
||||
((NOT (Y-OR-N-P "Do you want me to solve another one?"))) ) )
|
||||
|
||||
(DEFUN EIGHTS-AUX (START GOAL OPEN CLOSED NODE0 NODEI
|
||||
NODEJ SUCCESSORS NEXPANSIONS N TEMPOPEN)
|
||||
((NOT (SOLVABLE START))
|
||||
(WRITE-LINE "That is an impossible starting position.")
|
||||
(TERPRI) )
|
||||
(SETQ NODE0 START)
|
||||
(SETQ GOAL '(1 2 3 4 5 6 7 8 9))
|
||||
(SETQ N (SETQ NEXPANSIONS 0))
|
||||
(SETQ OPEN (LIST (LIST (F* NODE0 N) N NODE0 NIL)))
|
||||
(LOOP
|
||||
(PRINC '*)
|
||||
(SETQ OPEN (APPEND TEMPOPEN OPEN))
|
||||
(SETQ OPEN (DELETE (SETQ NODEI (GET-MIN-NODE OPEN GOAL)) OPEN 'EQUAL))
|
||||
(PUSH NODEI CLOSED)
|
||||
((EQUAL (CADDR NODEI) GOAL)
|
||||
(OUTPUT-SOLUTION START NODEI CLOSED NEXPANSIONS) )
|
||||
(SETQ SUCCESSORS (EXPAND-NODE (CADDR NODEI)))
|
||||
(SETQ N (ADD1 (CADR NODEI)))
|
||||
(SETQ TEMPOPEN NIL)
|
||||
(LOOP
|
||||
((NULL SUCCESSORS))
|
||||
(INCQ NEXPANSIONS)
|
||||
(SETQ NODEJ (LIST (F* (CAR SUCCESSORS) N) N (CAR SUCCESSORS)
|
||||
(CADDR NODEI)))
|
||||
(SETQ INOPEN (CONTAINED-INP OPEN NODEJ))
|
||||
(SETQ INCLOSED (CONTAINED-INP CLOSED NODEJ))
|
||||
( ((AND (NULL INOPEN) (NULL INCLOSED))
|
||||
(PUSH NODEJ TEMPOPEN) )
|
||||
((AND (NULL INOPEN) (< (CAR NODEJ) (CAR INCLOSED)))
|
||||
(SETQ CLOSED (DELETE (GET-MIN-NODE CLOSED (CADDR NODEJ))
|
||||
CLOSED 'EQUAL))
|
||||
(PUSH NODEJ TEMPOPEN) )
|
||||
((AND (NULL INCLOSED) (< (CAR NODEJ) (CAR INOPEN)))
|
||||
(SETQ OPEN (DELETE (GET-MIN-NODE OPEN (CADDR NODEJ)) OPEN 'EQUAL))
|
||||
(PUSH NODEJ TEMPOPEN) ) )
|
||||
(POP SUCCESSORS) ) ) )
|
||||
|
||||
(DEFUN CONTAINED-INP (LST NODE TEMP)
|
||||
(SETQ NODE (CADDR NODE))
|
||||
(LOOP
|
||||
((NULL LST) NIL)
|
||||
(SETQ TEMP (POP LST))
|
||||
((EQUAL (CADDR TEMP) NODE) TEMP) ) )
|
||||
|
||||
(DEFUN EXPAND-NODE (NODE)
|
||||
(MAPCAR 'XCHG-POS (NTH (POSITION 9 NODE) MOVE-LIST)) )
|
||||
|
||||
(DEFUN XCHG-POS (PAIR LST TEMP1 TEMP2)
|
||||
(SETQ LST (COPY-LIST NODE))
|
||||
(SETQ TEMP1 (NTHCDR (CAR PAIR) LST))
|
||||
(SETQ TEMP2 (NTHCDR (CADR PAIR) LST))
|
||||
(SETQ TEMP (CAR TEMP2))
|
||||
(RPLACA TEMP2 (CAR TEMP1))
|
||||
(RPLACA TEMP1 TEMP) LST )
|
||||
|
||||
(SETQ MOVE-LIST '(((0 1) (0 7)) ((0 1) (1 2) (1 8))
|
||||
((1 2) (2 3)) ((3 8) (2 3) (3 4))
|
||||
((4 5) (3 4)) ((5 6) (4 5) (5 8))
|
||||
((5 6) (6 7)) ((7 8) (0 7) (6 7))
|
||||
((7 8) (3 8) (1 8) (5 8)) ) )
|
||||
|
||||
(SETQ POS-LIST '((0 1 2 3 4 3 2 1 0) (1 0 1 2 3 2 3 2 0)
|
||||
(2 1 0 1 2 3 4 3 0) (3 2 1 0 1 2 3 2 0)
|
||||
(4 3 2 1 0 1 2 3 0) (3 2 3 2 1 0 1 2 0)
|
||||
(2 3 4 3 2 1 0 1 0) (1 2 3 2 3 2 1 0 0)
|
||||
(2 1 2 1 2 1 2 1 0) ) )
|
||||
|
||||
(DEFUN F* (LAYOUT N)
|
||||
(+ N (H* LAYOUT N)) )
|
||||
|
||||
(DEFUN H* (LAYOUT N PWEIGHT SWEIGHT)
|
||||
(SETQ PWEIGHT 1) (SETQ SWEIGHT 3) ; Adjustable weights
|
||||
(+ (* PWEIGHT (P* LAYOUT N)) (* SWEIGHT (S* LAYOUT N))))
|
||||
|
||||
(DEFUN P* (LAYOUT N SUM POSITION)
|
||||
(SETQ SUM 0)
|
||||
(SETQ POSITION POS-LIST)
|
||||
(LOOP
|
||||
((NULL LAYOUT) SUM)
|
||||
(INCQ SUM (NTH (+ (POP LAYOUT) -1) (POP POSITION))) ) )
|
||||
|
||||
(DEFUN S* (LAYOUT N
|
||||
SUM NUM)
|
||||
(SETQ SUM 1)
|
||||
( ((EQ (CAR LAYOUT) 9)
|
||||
(SETQ LAYOUT (COPY-LIST (CDR LAYOUT))) )
|
||||
((EQ (CAR (LAST LAYOUT)) 9)
|
||||
(SETQ SUM 0)
|
||||
(SETQ LAYOUT (COPY-LIST LAYOUT)) )
|
||||
(SETQ LAYOUT (REMOVE 9 LAYOUT)) )
|
||||
(RPLACA (LAST LAYOUT) (CAR LAYOUT))
|
||||
(LOOP
|
||||
(SETQ NUM (POP LAYOUT))
|
||||
((NULL LAYOUT) SUM)
|
||||
( ((EQ NUM 8)
|
||||
((EQ (CAR LAYOUT) 1))
|
||||
(INCQ SUM 2) )
|
||||
((EQ (ADD1 NUM) (CAR LAYOUT)))
|
||||
(INCQ SUM 2) ) ) )
|
||||
|
||||
(DEFUN GET-MIN-NODE (NODE-LST CONSTANT
|
||||
MIN-NODE)
|
||||
(SETQ MIN-NODE (POP NODE-LST))
|
||||
(LOOP
|
||||
((NULL NODE-LST) MIN-NODE)
|
||||
(SETQ NODE (POP NODE-LST))
|
||||
((EQUAL (CADDR NODE) CONSTANT) NODE)
|
||||
( ((> (CAR MIN-NODE) (CAR NODE))
|
||||
(SETQ MIN-NODE NODE) )
|
||||
((AND (EQUAL (CAR MIN-NODE) (CAR NODE))
|
||||
(> (CADR MIN-NODE) (CADR NODE)) )
|
||||
(SETQ MIN-NODE NODE) ) ) ) )
|
||||
|
||||
; SOLVABLE's algorthm is from "Mathematical Games and Pastimes"
|
||||
; by A. P. Domoryad; Macmillan Co., 1964, Pgs 79-85.
|
||||
|
||||
(DEFUN SOLVABLE (LST
|
||||
FLAG)
|
||||
(MAPC '(LAMBDA (NUM) (DISORDER NUM LST)) LST)
|
||||
(EQ (NOT FLAG) (EVENP (POSITION 9 LST))) )
|
||||
|
||||
(DEFUN DISORDER (NUM LST)
|
||||
((EQ NUM (CAR LST)))
|
||||
((> (CAR LST) NUM)
|
||||
(SETQ FLAG (NOT FLAG))
|
||||
(DISORDER NUM (CDR LST)) )
|
||||
(DISORDER NUM (CDR LST)) )
|
||||
|
||||
|
||||
(DEFUN OUTPUT-SOLUTION (START LASTNODE LST EXPANSIONS
|
||||
LST1 PRINTLIST)
|
||||
(TERPRI 2)
|
||||
(WRITE-STRING "The number of moves checked was ") (PRINC EXPANSIONS)
|
||||
(WRITE-LINE " and the shortest sequence is:") (TERPRI)
|
||||
(LOOP
|
||||
(PUSH (CADDR LASTNODE) PRINTLIST)
|
||||
(SETQ LST1 LST)
|
||||
(LOOP
|
||||
((EQUAL (CAR (CDDDR LASTNODE)) (CADDR (CAR LST1)))
|
||||
(SETQ LASTNODE (CAR LST1)) )
|
||||
(POP LST1) )
|
||||
((NULL (CAR (CDDDR LASTNODE)))
|
||||
(FORMAT-OUTPUT (PUSH START PRINTLIST)) ) ) )
|
||||
|
||||
(DEFUN FORMAT-OUTPUT (ANSWERS DISPLAY# S1 S2 S3 COUNTER)
|
||||
(SETQ DISPLAY# (TRUNCATE (+ 2 (LINELENGTH)) 7))
|
||||
(LOOP ; Prints DISPLAY# of squares
|
||||
((NULL (CAR ANSWERS))) ; across the page from a list
|
||||
(SETQ COUNTER 0) ; of lists in ANSWERS
|
||||
(SETQ S1)
|
||||
(LOOP
|
||||
((EQUAL COUNTER DISPLAY#))
|
||||
(SETQ S2 (POP ANSWERS))
|
||||
((NULL S2))
|
||||
(PUSH S2 S1)
|
||||
(INCQ COUNTER) )
|
||||
(SETQ DISPLAY# COUNTER)
|
||||
(SETQ S1 (REVERSE S1))
|
||||
(PRINT-ROW S1 DISPLAY# '(0 1 2))
|
||||
(PRINT-ROW S1 DISPLAY# '(7 8 3))
|
||||
(PRINT-ROW S1 DISPLAY# '(6 5 4))
|
||||
(TERPRI) ) )
|
||||
|
||||
(DEFUN PRINT-ROW (LST DISPLAY# INDEX-LIST)
|
||||
(LOOP
|
||||
((ZEROP DISPLAY#) (TERPRI))
|
||||
(PRIN3 (NTH (CAR INDEX-LIST) (CAR LST)))
|
||||
(PRIN3 (NTH (CADR INDEX-LIST) (CAR LST)))
|
||||
(PRIN3 (NTH (CADDR INDEX-LIST) (POP LST)))
|
||||
(SPACES 1)
|
||||
(DECQ DISPLAY#) ) )
|
||||
|
||||
(DEFUN PRIN3 (NUM)
|
||||
((EQ NUM 9)
|
||||
(WRITE-STRING " ") )
|
||||
(PRINC NUM)
|
||||
(SPACES 1) )
|
||||
|
||||
(DEFUN READ-ROW (ROW COL LST
|
||||
READ-CHAR)
|
||||
(LOOP
|
||||
(SET-CURSOR ROW COL)
|
||||
(LOOP
|
||||
(SETQ CHAR (READ-CHAR))
|
||||
((EQ CHAR (ASCII 3)) ;Abort EIGHTS if <CTRL-C> typed
|
||||
(THROW) )
|
||||
( ((EQ CHAR '" "))
|
||||
(SETQ CHAR (- (ASCII CHAR) 48)) )
|
||||
((MEMBER CHAR LEGAL-LST))
|
||||
(PRINC (ASCII 7)) )
|
||||
(SETQ LEGAL-LST (REMOVE CHAR LEGAL-LST))
|
||||
( ((EQ (PRINC CHAR) '" ")
|
||||
(SETQ CHAR 9) ) )
|
||||
(RPLACA (NTHCDR (POP LST) RSLT-LST) CHAR)
|
||||
((NULL LST))
|
||||
(INCQ COL 4) ) )
|
||||
|
||||
(DEFUN CENTER (MSG)
|
||||
(SET-CURSOR (ROW)
|
||||
(TRUNCATE (- (CADDDR (MAKE-WINDOW)) (LENGTH MSG)) 2))
|
||||
(WRITE-LINE MSG) )
|
||||
|
||||
(DEFUN Y-OR-N-P (MSG
|
||||
CHAR READ-CHAR RDS WRS )
|
||||
( ((NULL MSG))
|
||||
(FRESH-LINE)
|
||||
(WRITE-STRING (PACK* MSG " (Y/N) ")) )
|
||||
(CLEAR-INPUT)
|
||||
(LOOP
|
||||
(SETQ CHAR (CHAR-UPCASE (READ-CHAR)))
|
||||
((EQ CHAR 'Y)
|
||||
(WRITE-LINE CHAR)
|
||||
T )
|
||||
((EQ CHAR 'N)
|
||||
(WRITE-LINE CHAR)
|
||||
NIL )
|
||||
(WRITE-BYTE 7) ) )
|
||||
|
||||
(EIGHTS (RDS))
|
||||
|
||||
220
Microsoft muLISP-86 v51/GRAPHICS.LSP
Normal file
220
Microsoft muLISP-86 v51/GRAPHICS.LSP
Normal file
@ -0,0 +1,220 @@
|
||||
;File: GRAPHICS.LSP (c) 12/27/85 Soft Warehouse, Inc.
|
||||
|
||||
|
||||
; This file contains the graphics functions defined in muLISP Lesson #6.
|
||||
|
||||
(SETQ COLUMNS 80) ; Number of columns on your screen.
|
||||
|
||||
(SETQ ROWS 24) ; Number of rows on your screen.
|
||||
|
||||
; DOT is the character graphics primitive function. It requires that
|
||||
; (SET-CURSOR row column) be properly defined for your computer and terminal.
|
||||
|
||||
(DEFUN DOT (X-COORD Y-COORD
|
||||
LINELENGTH )
|
||||
((AND (< (- X-MAX) X-COORD X-MAX)
|
||||
(< (- Y-MAX) Y-COORD Y-MAX) )
|
||||
(SET-CURSOR (- Y-MAX Y-COORD) (+ X-MAX X-COORD))
|
||||
(PRIN1 DOT) ) )
|
||||
|
||||
(SETQ X-MAX (TRUNCATE (ADD1 COLUMNS) 2))
|
||||
|
||||
(SETQ Y-MAX (TRUNCATE (ADD1 ROWS) 2))
|
||||
|
||||
(SETQ DOT '*)
|
||||
|
||||
(DEFUN DRAW (NLAMBDA COMMANDS
|
||||
(CLEAR-SCREEN)
|
||||
(MAPC 'EVAL COMMANDS)
|
||||
(SET-CURSOR 0 0) ))
|
||||
|
||||
(DEFUN LINE (X1 Y1 X2 Y2
|
||||
DELTA-X DELTA-Y SIGN-DELTA-X SIGN-DELTA-Y)
|
||||
(SETQ DELTA-X (- X2 X1)
|
||||
DELTA-Y (- Y2 Y1)
|
||||
SIGN-DELTA-X (SIGNUM DELTA-X)
|
||||
SIGN-DELTA-Y (SIGNUM DELTA-Y)
|
||||
DELTA-X (ABS DELTA-X)
|
||||
DELTA-Y (ABS DELTA-Y))
|
||||
((< DELTA-Y DELTA-X)
|
||||
(SETQ DELTA-Y (+ DELTA-Y DELTA-Y) ;Gentle slope
|
||||
Y2 (- DELTA-Y DELTA-X)
|
||||
DELTA-X (- DELTA-X Y2))
|
||||
(LOOP
|
||||
(DOT X1 Y1)
|
||||
((EQ X1 X2))
|
||||
( ((PLUSP Y2)
|
||||
(INCQ Y1 SIGN-DELTA-Y)
|
||||
(DECQ Y2 DELTA-X) )
|
||||
(INCQ Y2 DELTA-Y) )
|
||||
(INCQ X1 SIGN-DELTA-X) ) )
|
||||
(SETQ DELTA-X (+ DELTA-X DELTA-X) ;Steep slope
|
||||
X2 (- DELTA-X DELTA-Y)
|
||||
DELTA-Y (- DELTA-Y X2))
|
||||
(LOOP
|
||||
(DOT X1 Y1)
|
||||
((EQ Y1 Y2))
|
||||
( ((PLUSP X2)
|
||||
(INCQ X1 SIGN-DELTA-X)
|
||||
(DECQ X2 DELTA-Y) )
|
||||
(INCQ X2 DELTA-X) )
|
||||
(INCQ Y1 SIGN-DELTA-Y) ) )
|
||||
|
||||
|
||||
(DEFUN REDUCED-SIN (DEG)
|
||||
(/ (* DEG (+ 1324959969 (* (SETQ DEG (* DEG DEG)) (+ -67245 DEG))))
|
||||
75914915920) )
|
||||
|
||||
(DEFUN REDUCED-COS (DEG)
|
||||
(SETQ DEG (* DEG DEG))
|
||||
(/ (+ 266153374 (* DEG (+ -40518 DEG)))
|
||||
266153374) )
|
||||
|
||||
(DEFUN SIN-DEG (ANGLE)
|
||||
((MINUSP ANGLE)
|
||||
(SETQ ANGLE (DIVIDE (REM (- ANGLE) 360) 45))
|
||||
(- (SIN-COS-DEG (CAR ANGLE) (CDR ANGLE))) )
|
||||
(SETQ ANGLE (DIVIDE (REM ANGLE 360) 45))
|
||||
(SIN-COS-DEG (CAR ANGLE) (CDR ANGLE)) )
|
||||
|
||||
(DEFUN COS-DEG (ANGLE)
|
||||
(SETQ ANGLE (DIVIDE (REM (ABS ANGLE) 360) 45))
|
||||
(SIN-COS-DEG (+ 2 (CAR ANGLE)) (CDR ANGLE)) )
|
||||
|
||||
(DEFUN SIN-COS-DEG (N45DEG RESID)
|
||||
((> N45DEG 3)
|
||||
(- (SIN-COS-DEG (- N45DEG 4) RESID)) )
|
||||
((ZEROP N45DEG) (REDUCED-SIN RESID))
|
||||
((EQL N45DEG 1) (REDUCED-COS (- 45 RESID)))
|
||||
((EQL N45DEG 2) (REDUCED-COS RESID))
|
||||
(REDUCED-SIN (- 45 RESID)) )
|
||||
|
||||
|
||||
(DEFUN SETPOS (X Y)
|
||||
(SETQ X-POS X Y-POS Y) )
|
||||
|
||||
(DEFUN TURN (ANGLE)
|
||||
(SETQ HEADING (REM (+ HEADING ANGLE) 360)) )
|
||||
|
||||
(DEFUN SETHEADING (ANGLE)
|
||||
(SETQ HEADING (REM ANGLE 360)) )
|
||||
|
||||
(DEFUN PENDOWN ()
|
||||
(SETQ PENDOWN T) )
|
||||
|
||||
(DEFUN PENUP ()
|
||||
(SETQ PENDOWN NIL) )
|
||||
|
||||
|
||||
(DEFUN TURTLE (NLAMBDA COMMANDS
|
||||
(SETPOS 0 0)
|
||||
(SETHEADING 0)
|
||||
(PENDOWN)
|
||||
(APPLY 'DRAW COMMANDS) ))
|
||||
|
||||
(DEFUN FORWARD (DISTANCE
|
||||
X-OLD Y-OLD )
|
||||
(SETQ X-OLD X-POS)
|
||||
(SETQ Y-OLD Y-POS)
|
||||
(INCQ X-POS (ROUND (* DISTANCE (SIN-DEG HEADING))))
|
||||
(INCQ Y-POS (ROUND (* DISTANCE (COS-DEG HEADING))))
|
||||
((NOT PENDOWN))
|
||||
(LINE X-OLD Y-OLD X-POS Y-POS) )
|
||||
|
||||
(DEFUN FORWARD-THEN-TURN (DISTANCE ANGLE)
|
||||
(FORWARD DISTANCE)
|
||||
(TURN ANGLE) )
|
||||
|
||||
|
||||
(DEFUN POLY (SIDE ANGLE
|
||||
TOT-TURN)
|
||||
(SETQ TOT-TURN 0)
|
||||
(LOOP
|
||||
(FORWARD-THEN-TURN SIDE ANGLE)
|
||||
(SETQ TOT-TURN (REM (+ TOT-TURN ANGLE) 360))
|
||||
((ZEROP TOT-TURN)) ) )
|
||||
|
||||
(DEFUN CORN-POL (SIDE ANGLE
|
||||
TOT-TURN)
|
||||
((> SIDE 1)
|
||||
(SETQ TOT-TURN 0)
|
||||
(LOOP
|
||||
(FORWARD SIDE)
|
||||
(CORN-POL (SHIFT SIDE -2) (- ANGLE))
|
||||
(TURN ANGLE)
|
||||
(SETQ TOT-TURN (REM (+ TOT-TURN ANGLE) 360))
|
||||
((ZEROP TOT-TURN)) ) ) )
|
||||
|
||||
(DEFUN SPIRAL (SIDE ANGLE INCR)
|
||||
(LOOP
|
||||
((< SIDE INCR))
|
||||
(FORWARD-THEN-TURN SIDE ANGLE)
|
||||
(DECQ SIDE INCR) ) )
|
||||
|
||||
(DEFUN SPIROLAT (SIDE ANGLE INCR
|
||||
TOT-TURN)
|
||||
(SETQ TOT-TURN 0)
|
||||
(LOOP
|
||||
(SPIRAL SIDE ANGLE INCR)
|
||||
(SETQ TOT-TURN (REM (+ TOT-TURN (* ANGLE (TRUNCATE SIDE INCR))) 360))
|
||||
((ZEROP TOT-TURN)) ) )
|
||||
|
||||
(DEFUN IBM-DOT (X-COORD Y-COORD)
|
||||
((AND (< -161 X-COORD 160)
|
||||
(< -101 Y-COORD 100) )
|
||||
(REGISTER 2 (+ 160 X-COORD))
|
||||
(REGISTER 3 (- 100 Y-COORD))
|
||||
(REGISTER 0 *COLOR*)
|
||||
(INTERRUPT 16) ) )
|
||||
|
||||
(MOVD 'IBM-DOT 'DOT) ;Use IBM plot dot routine
|
||||
|
||||
(DEFUN SETCOLOR (COLOR)
|
||||
(SETQ *COLOR* (+ 3071 (LENGTH (MEMBER COLOR
|
||||
'(WHITE RED GREEN BLACK))))) )
|
||||
|
||||
(SETCOLOR WHITE)
|
||||
|
||||
(DEFUN GRAPHICS-MODE () ;Sets up 320 x 200 color graphics mode
|
||||
(REGISTER 0 4)
|
||||
(INTERRUPT 16)
|
||||
(MAKE-WINDOW 0 0 25 40) )
|
||||
|
||||
(DEFUN ALPHA-MODE () ;Sets up 25 x 80 color alpha mode
|
||||
(REGISTER 0 3)
|
||||
(INTERRUPT 16)
|
||||
(CURSOR-LINES NIL)
|
||||
(MAKE-WINDOW 0 0 25 80) )
|
||||
|
||||
(DEFUN TURTLE (NLAMBDA COMMANDS
|
||||
(IF (NEQ (CADDDR (MAKE-WINDOW)) 40) (GRAPHICS-MODE) )
|
||||
(MAKE-WINDOW 0 0 21 40)
|
||||
(SETPOS 0 0)
|
||||
(SETHEADING 0)
|
||||
(PENDOWN)
|
||||
(CATCH 'DRIVER (APPLY 'DRAW COMMANDS))
|
||||
(MAKE-WINDOW 21 0 4 40)
|
||||
(SET-CURSOR 3 0) ))
|
||||
|
||||
(DEFUN C-CURVE (DEPTH) ;"C" curve function
|
||||
((ZEROP DEPTH)
|
||||
(FORWARD *LENGTH*) )
|
||||
(TURN 45)
|
||||
(C-CURVE (SUB1 DEPTH))
|
||||
(TURN -90)
|
||||
(C-CURVE (SUB1 DEPTH))
|
||||
(TURN 45) )
|
||||
|
||||
(SETQ *LENGTH* 3)
|
||||
|
||||
(DEFUN D-CURVE (DEPTH FLAG) ;"Dragon" curve function
|
||||
((ZEROP DEPTH)
|
||||
(FORWARD *LENGTH*) )
|
||||
(IF FLAG (TURN 45) (TURN -45))
|
||||
(D-CURVE (SUB1 DEPTH) T)
|
||||
(IF FLAG (TURN -90) (TURN 90))
|
||||
(D-CURVE (SUB1 DEPTH) NIL)
|
||||
(IF FLAG (TURN 45) (TURN -45)) )
|
||||
|
||||
(RDS)
|
||||
|
||||
145
Microsoft muLISP-86 v51/HANOI.LSP
Normal file
145
Microsoft muLISP-86 v51/HANOI.LSP
Normal file
@ -0,0 +1,145 @@
|
||||
; File: HANOI.LSP (c) 12/29/85 Soft Warehouse, Inc.
|
||||
|
||||
|
||||
; * * * The Tower of Hanoi Puzzle * * *
|
||||
|
||||
(LOOP (PRIN1 (QUOTE *)) (EVAL (READ)) ((NULL RDS)) )
|
||||
|
||||
(SETQ *BLOCK-CHAR* (ASCII 219)) ; Character used to make rings
|
||||
|
||||
(DEFUN HANOI (
|
||||
*RINGS* *HIGH-SPEED* *COLOR* *TONE* *TIME* *ROWS* MAX-RINGS
|
||||
PEG1-RINGS PEG2-RINGS PEG3-RINGS PEG1-COLUMN PEG2-COLUMN PEG3-COLUMN
|
||||
*AUTO-NEWLINE* )
|
||||
(SETQ *ROWS* (CADDR (MAKE-WINDOW)))
|
||||
(LOOP
|
||||
(SETQ *TIME* 120)
|
||||
(CLEAR-SCREEN)
|
||||
(SETQ *HIGH-INTENSITY* T)
|
||||
(CENTER "T H E T O W E R O F H A N O I")
|
||||
(SETQ *HIGH-INTENSITY*)
|
||||
(CLEAR-INPUT)
|
||||
(TERPRI 2)
|
||||
(SETQ MAX-RINGS (MIN
|
||||
(TRUNCATE (SUB1 (TRUNCATE (CADDDR (MAKE-WINDOW)) 2)) 3)
|
||||
(SUB1 (CADDR (MAKE-WINDOW))) ))
|
||||
(LOOP
|
||||
(WRITE-STRING (PACK* " Number of rings to use (1 to " MAX-RINGS ")? "))
|
||||
((AND
|
||||
(SETQ *RINGS* (SYMBOL-TO-INTEGER (READ-LINE)))
|
||||
(<= 1 *RINGS* MAX-RINGS))) )
|
||||
(TERPRI)
|
||||
(SETQ *HIGH-SPEED* (NOT (Y-OR-N-P " Run program at normal speed?")))
|
||||
( ((NOT *HIGH-SPEED*)
|
||||
(TERPRI)
|
||||
(SETQ *TONE* (Y-OR-N-P " Do you want sound effects?")) ) )
|
||||
(TERPRI)
|
||||
(SETQ *COLOR* (Y-OR-N-P "Are you using a color monitor?"))
|
||||
(CLEAR-SCREEN)
|
||||
(SETQ *HIGH-INTENSITY* T)
|
||||
(CENTER "T H E T O W E R O F H A N O I")
|
||||
(SETQ *HIGH-INTENSITY*)
|
||||
(PUT 'PEG2 'COLUMN (TRUNCATE (CADDDR (MAKE-WINDOW)) 2))
|
||||
(PUT 'PEG1 'COLUMN (- (GET PEG2 'COLUMN) *RINGS* *RINGS* 1))
|
||||
(PUT 'PEG3 'COLUMN (+ (GET PEG2 'COLUMN) *RINGS* *RINGS* 1))
|
||||
(PRINT-PEG *RINGS* *ROWS* (GET 'PEG1 'COLUMN))
|
||||
(PRINT-PEG *RINGS* *ROWS* (GET 'PEG2 'COLUMN))
|
||||
(PRINT-PEG *RINGS* *ROWS* (GET 'PEG3 'COLUMN))
|
||||
(PUT PEG1 'RINGS (MAKE-TOWER *RINGS* *ROWS* (GET 'PEG1 'COLUMN)))
|
||||
(PUT PEG2 'RINGS NIL)
|
||||
(PUT PEG3 'RINGS NIL)
|
||||
(UNWIND-PROTECT (MOVE-RINGS *RINGS* 'PEG1 'PEG2 'PEG3)
|
||||
(FOREGROUND-COLOR 7) )
|
||||
(SET-CURSOR 2 0)
|
||||
((NOT (Y-OR-N-P "Run the puzzle again?"))) ) )
|
||||
|
||||
(DEFUN MOVE-RINGS (RINGS SOURCE-PEG TARGET-PEG SPARE-PEG
|
||||
SOURCE-RINGS )
|
||||
((ZEROP RINGS))
|
||||
(MOVE-RINGS (SUB1 RINGS) SOURCE-PEG SPARE-PEG TARGET-PEG)
|
||||
(SETQ SOURCE-RINGS (GET SOURCE-PEG 'RINGS))
|
||||
(PUT TARGET-PEG 'RINGS (CONS (CAR SOURCE-RINGS) (GET TARGET-PEG 'RINGS)))
|
||||
(PUT SOURCE-PEG 'RINGS (CDR SOURCE-RINGS))
|
||||
(SET-CURSOR (- *ROWS* (LENGTH SOURCE-RINGS))
|
||||
(- (GET SOURCE-PEG 'COLUMN) (CAAR SOURCE-RINGS)))
|
||||
(SPACES (CAAR SOURCE-RINGS))
|
||||
(PRINC *BLOCK-CHAR*)
|
||||
(SPACES (CAAR SOURCE-RINGS))
|
||||
(IF *COLOR* (FOREGROUND-COLOR (CAAR SOURCE-RINGS)))
|
||||
( ((IDENTITY *HIGH-SPEED*))
|
||||
(PRINT-RING (CAAR SOURCE-RINGS) (CDAR SOURCE-RINGS) SOURCE-PEG *TIME*)
|
||||
(IF (OR (EQ SOURCE-PEG 'PEG2) (EQ TARGET-PEG 'PEG2)) NIL
|
||||
(PRINT-RING (CAAR SOURCE-RINGS) (CDAR SOURCE-RINGS) 'PEG2 *TIME*) )
|
||||
(PRINT-RING (CAAR SOURCE-RINGS) (CDAR SOURCE-RINGS) TARGET-PEG *TIME*) )
|
||||
(SET-CURSOR (- *ROWS* (LENGTH (GET TARGET-PEG 'RINGS)))
|
||||
(- (GET TARGET-PEG 'COLUMN) (CAAR SOURCE-RINGS)))
|
||||
(PRINC (CDAR SOURCE-RINGS))
|
||||
(IF *COLOR* (FOREGROUND-COLOR 7))
|
||||
(IF *HIGH-SPEED* NIL (TONE NIL *TIME*))
|
||||
; (IF (> *TIME* 10) (DECQ *TIME*)) ;Optional accelerator
|
||||
(MOVE-RINGS (SUB1 RINGS) SPARE-PEG TARGET-PEG SOURCE-PEG) )
|
||||
|
||||
(DEFUN PRINT-RING (RING-SIZE RING-STRING PEG TIME)
|
||||
((SET-CURSOR (- *ROWS* *RINGS* 3) (- (GET PEG 'COLUMN) RING-SIZE))
|
||||
(WRITE-STRING RING-STRING)
|
||||
(SET-CURSOR (- *ROWS* *RINGS* 3) (- (GET PEG 'COLUMN) RING-SIZE))
|
||||
(TONE (IF *TONE* (CDR (ASSOC (CAAR SOURCE-RINGS) *NOTES*))) TIME)
|
||||
(SPACES (ADD1 (* 2 RING-SIZE))) )
|
||||
(TONE (IF *TONE* (CDR (ASSOC (CAAR SOURCE-RINGS) *NOTES*))) TIME) )
|
||||
|
||||
(SETQ *NOTES* '((1 . 523) (2 . 494) (3 . 440) (4 . 392) (5 . 349) (6 . 330)
|
||||
(7 . 294) (8 . 262) (9 . 247) (10 . 220) (11 . 196) (12 . 175)
|
||||
(13 . 165) (14 . 147) (15 . 131)))
|
||||
|
||||
(DEFUN PRINT-PEG (RINGS ROW COLUMN)
|
||||
(LOOP
|
||||
(SET-CURSOR (DECQ ROW) COLUMN)
|
||||
(PRINC *BLOCK-CHAR*)
|
||||
((ZEROP RINGS))
|
||||
(DECQ RINGS) ) )
|
||||
|
||||
(DEFUN MAKE-TOWER (RINGS ROW COLUMN
|
||||
PEG-RINGS )
|
||||
(LOOP
|
||||
((ZEROP RINGS)
|
||||
(IF *COLOR* (FOREGROUND-COLOR 7))
|
||||
PEG-RINGS )
|
||||
(PUSH (CONS RINGS (PACK (MAKE-LIST (ADD1 (* 2 RINGS)) *BLOCK-CHAR*)))
|
||||
PEG-RINGS)
|
||||
(SET-CURSOR (DECQ ROW) (- COLUMN RINGS))
|
||||
(IF *COLOR* (FOREGROUND-COLOR RINGS))
|
||||
(PRINC (CDAR PEG-RINGS))
|
||||
(DECQ RINGS) ) )
|
||||
|
||||
(DEFUN CENTER (MSG)
|
||||
(SET-CURSOR (ROW)
|
||||
(TRUNCATE (- (CADDDR (MAKE-WINDOW)) (LENGTH MSG)) 2))
|
||||
(WRITE-LINE MSG) )
|
||||
|
||||
(DEFUN SYMBOL-TO-INTEGER (SYMBOL
|
||||
NUM )
|
||||
((SETQ SYMBOL (UNPACK SYMBOL))
|
||||
(SETQ NUM 0)
|
||||
(LOOP
|
||||
((NOT (<= 48 (ASCII (CAR SYMBOL)) 57)) NIL)
|
||||
(SETQ NUM (+ (* NUM 10) (- (ASCII (POP SYMBOL)) 48)))
|
||||
((NULL SYMBOL) NUM) ) ) )
|
||||
|
||||
(DEFUN Y-OR-N-P (MSG
|
||||
CHAR READ-CHAR RDS WRS )
|
||||
( ((NULL MSG))
|
||||
(FRESH-LINE)
|
||||
(WRITE-STRING (PACK* MSG " (Y/N) ")) )
|
||||
(CLEAR-INPUT)
|
||||
(LOOP
|
||||
(SETQ CHAR (CHAR-UPCASE (READ-CHAR)))
|
||||
((EQ CHAR 'Y)
|
||||
(WRITE-LINE CHAR)
|
||||
T )
|
||||
((EQ CHAR 'N)
|
||||
(WRITE-LINE CHAR)
|
||||
NIL )
|
||||
(WRITE-BYTE 7) ) )
|
||||
|
||||
(HANOI (RDS))
|
||||
|
||||
484
Microsoft muLISP-86 v51/HELP.LSP
Normal file
484
Microsoft muLISP-86 v51/HELP.LSP
Normal file
@ -0,0 +1,484 @@
|
||||
; File: HELP.LSP (C) 12/28/85 Soft Warehouse, Inc.
|
||||
|
||||
; muLISP Help Facility
|
||||
|
||||
; To use the Help Facility, read this file into muLISP using the RDS
|
||||
; command: (RDS HELP). Then if <name> is the name of a muLISP primitive,
|
||||
; the command (HELP 'name) displays <name>'s arguments or initial value
|
||||
; and <name>'s page number in Chapter 5 of the muLISP Reference Manual.
|
||||
|
||||
|
||||
(PROG1
|
||||
|
||||
(DEFUN HELP (NAME
|
||||
READ-CHAR RDS WRS )
|
||||
(SETQ READ-CHAR 0)
|
||||
(LOOP
|
||||
(FRESH-LINE)
|
||||
((GET NAME 'HELP-POINTER)
|
||||
((RDS *HELP-FILE*)
|
||||
(READPTR (GET NAME 'HELP-POINTER))
|
||||
(WRITE-LINE (READ-LINE))
|
||||
T )
|
||||
(WRITE-LINE (PACK* *HELP-FILE* "not found"))
|
||||
NIL )
|
||||
(WRITE-STRING "Enter primitive name: ")
|
||||
(CLEAR-INPUT)
|
||||
(SETQ NAME (STRING-UPCASE (READ-LINE)))
|
||||
((EQ NAME '||)) ) )
|
||||
|
||||
(MOVD 'HELP '?)
|
||||
|
||||
(SETQ *HELP-FILE* (INPUTFILE))
|
||||
|
||||
(LOOP
|
||||
((NOT (LISTEN))
|
||||
(TERPRI 2)
|
||||
(WRITE-LINE
|
||||
"For help on the muLISP primitive <name>, enter: (HELP name)")
|
||||
(SETQ RDS) )
|
||||
((LAMBDA (NUM LINE)
|
||||
((EQ LINE ||))
|
||||
(PUT (STRING-RIGHT-TRIM |: | (SUBSTRING LINE 0 (FINDSTRING '| | LINE)))
|
||||
'HELP-POINTER NUM))
|
||||
(READPTR)
|
||||
(READ-LINE)) ) )
|
||||
|
||||
ABS [n] Numerical Function 139
|
||||
ACONS [key, object, alist] Constructor Function 36
|
||||
ACOS [n] Numerical Function 137
|
||||
ADD1 [n] Numerical Function 126
|
||||
ADJOIN [object, list, test] Constructor Function 33
|
||||
ALLOCATE [n] Memory Function 236
|
||||
ALPHA-CHAR-P [symbol] Character Function 90
|
||||
ALPHANUMERICP [symbol] Character Function 90
|
||||
AND [form1, ... formn] Logical Special form 66
|
||||
APPEND [list1, ... listn] Constructor Function 21
|
||||
APPLY [function, arg1, ..., list] Evaluator Function 201
|
||||
ASCII [atom] Character Function 94
|
||||
ASH [n, m] Numerical Function 150
|
||||
ASIN [n] Numerical Function 137
|
||||
ASSOC [key, alist, test] Searcher Function 16
|
||||
ASSOC-IF [test, alist] Searcher Function 16
|
||||
ATAN [n] Numerical Function 137
|
||||
ATOM [object] Recognizer Function 56
|
||||
*AUTO-NEWLINE*: T Screen Control var. 265
|
||||
|
||||
BACKGROUND-COLOR [n] Screen Function 263
|
||||
BINARY-LOAD [filename, offset] Hardware Function 255
|
||||
*BLINK*: NIL Screen Control var. 265
|
||||
BREAK [object, message] User interface Function 243
|
||||
BUTLAST [list, n] Constructor Function 26
|
||||
|
||||
CAAAAR [object] Selector Function 5
|
||||
CAAADR [object] Selector Function 5
|
||||
CAAAR [object] Selector Function 5
|
||||
CAADAR [object] Selector Function 5
|
||||
CAADDR [object] Selector Function 5
|
||||
CAADR [object] Selector Function 5
|
||||
CAAR [object] Selector Function 5
|
||||
CADAAR [object] Selector Function 5
|
||||
CADADR [object] Selector Function 5
|
||||
CADAR [object] Selector Function 5
|
||||
CADDAR [object] Selector Function 5
|
||||
CADDDR [object] Selector Function 5
|
||||
CADDR [object] Selector Function 5
|
||||
CADR [object] Selector Function 5
|
||||
CAR [object] Selector Function 5
|
||||
CATCH [label, form1, ...] Control Special form 226
|
||||
CDAAAR [object] Selector Function 5
|
||||
CDAADR [object] Selector Function 5
|
||||
CDAAR [object] Selector Function 5
|
||||
CDADAR [object] Selector Function 5
|
||||
CDADDR [object] Selector Function 5
|
||||
CDADR [object] Selector Function 5
|
||||
CDAR [object] Selector Function 5
|
||||
CDDAAR [object] Selector Function 5
|
||||
CDDADR [object] Selector Function 5
|
||||
CDDAR [object] Selector Function 5
|
||||
CDDDAR [object] Selector Function 5
|
||||
CDDDDR [object] Selector Function 5
|
||||
CDDDR [object] Selector Function 5
|
||||
CDDR [object] Selector Function 5
|
||||
CDR [object] Selector Function 4
|
||||
CEILING [n, m] Numerical Function 143
|
||||
CHAR [atom, n] String Function 100
|
||||
CHAR-CODE [symbol] Character Function 95
|
||||
CHAR-DOWNCASE [symbol] Character Function 96
|
||||
CHAR-EQUAL [sym1, ... symn] Character Function 93
|
||||
CHAR-GREATERP [sym1, ... symn] Character Function 93
|
||||
CHAR-LESSP [sym1, ... symn] Character Function 93
|
||||
CHAR-NOT-EQUAL [sym1, ... symn] Character Function 93
|
||||
CHAR-NOT-GREATERP [sym1, ... ] Character Function 93
|
||||
CHAR-NOT-LESSP [sym1, ... symn] Character Function 93
|
||||
CHAR-UPCASE [symbol] Character Function 96
|
||||
CHAR= [symbol1, ... symboln] Character Function 92
|
||||
CHAR< [symbol1, ... symboln] Character Function 92
|
||||
CHAR> [symbol1, ... symboln] Character Function 92
|
||||
CHAR<= [symbol1, ... symboln] Character Function 92
|
||||
CHAR>= [symbol1, ... symboln] Character Function 92
|
||||
CHAR/= [symbol1, ... symboln] Character Function 92
|
||||
CLEAR-INPUT [] Input Function 160
|
||||
CLEAR-SCREEN [] Screen Function 259
|
||||
CODE-CHAR [n] Character Function 95
|
||||
COLUMN [] Screen Function 259
|
||||
COMMENT [comments] Control Special form 225
|
||||
COND [cond1, ... condn] Control Special form 221
|
||||
CONS [obj1, obj2] Constructor Function 18
|
||||
CONSP [object] Recognizer Function 58
|
||||
CONSTANTP [object] Evaluator Function 197
|
||||
COPY-ALIST [alist] Constructor Function 22
|
||||
COPY-CHAR-TYPE [chr1, chr2, flg]Input Function 167
|
||||
COPY-LIST [list] Constructor Function 22
|
||||
COPY-TREE [object] Constructor Function 22
|
||||
COS [n] Numerical Function 136
|
||||
COUNT [object, list, test] Searcher Function 11
|
||||
COUNT-IF [test, list] Searcher Function 11
|
||||
CSMEMORY [offset, value, flag] Hardware Function 249
|
||||
CURSOR-LINES [start, endline] Screen Function 264
|
||||
|
||||
DECF [place, n] Numerical Macro 128
|
||||
DECQ [symbol, n] Numerical Special form 127
|
||||
DEFMACRO [sym, arglist, form1, ...] Definition Special form 88
|
||||
DEFUN [sym, arglist, form1, ...] Definition Special form 87
|
||||
DELETE [item, list, test] Modifier Function 44
|
||||
DELETE-DUPLICATES [list, test] Modifier Function 45
|
||||
DELETE-IF [test, list] Modifier Function 44
|
||||
DELETE-LINES [n] Screen Function 261
|
||||
DENOMINATOR [n] Numerical Function 141
|
||||
DIGIT-CHAR-P [symbol, n] Character Function 91
|
||||
DISPLAY-PAGE [n] Screen Function 265
|
||||
DIVIDE [n, m] Numerical Function 147
|
||||
DO [letlist, form1, ... formn] Control Macro 223
|
||||
DO* [letlist, form1, ... formn] Control Macro 223
|
||||
DOLIST [(var, list, result) form1, ...] Control Macro 224
|
||||
DOTIMES [(var, count, result) form1, ...] Control Macro 224
|
||||
DRIVER [] User interface Function 241
|
||||
DSMEMORY [offset, value, flag] Hardware Function 249
|
||||
|
||||
ECHO: NIL I/O Control var. 173, 190
|
||||
EIGHTH [list] Selector Function 7
|
||||
ENDP [object] Recognizer Function 59
|
||||
EOF I/O Keyword 159, 180
|
||||
EQ [obj1, obj2] Comparator Function 60
|
||||
EQL [obj1, obj2] Comparator Function 61
|
||||
EQUAL [obj1, obj2, test] Comparator Function 62
|
||||
EVAL [object] Evaluator Function 199
|
||||
EVAL-FUNCTION-P [symbol] Evaluator Function 196
|
||||
EVENP [object] Numerical Function 114
|
||||
EVERY [test, list1, ..., listn] Evaluator Function 212
|
||||
EXECUTE [program, command-line] Control Function 231
|
||||
EXP [n] Numerical Function 132
|
||||
EXPT [n, m] Numerical Function 133
|
||||
|
||||
FBOUNDP [symbol] Evaluator Function 196
|
||||
FIFTH [list] Selector Function 7
|
||||
FILL [list, object] Modifier Function 40
|
||||
FIND [object, list, test] Searcher Function 14
|
||||
FIND-IF [test, list] Searcher Function 14
|
||||
FINDSTRING [atom1, atom2, n] String Function 106
|
||||
FIRST [list] Selector Function 7
|
||||
FIRSTN [n, list] Constructor Function 23
|
||||
FLAG [symbol, attribute] Flag Function 79
|
||||
FLAGP [symbol, attribute] Flag Function 79
|
||||
FLOOR [n, m] Numerical Function 142
|
||||
FMAKUNBOUND [symbol] Definition Function 85
|
||||
FOREGROUND-COLOR [n] Screen Function 263
|
||||
FOURTH [list] Selector Function 7
|
||||
*FREE-LIST*: '*FREE-LIST* Memory Variable 235
|
||||
FRESH-LINE [] Output Function 185
|
||||
FUNCALL [function, arg1, ... arg2] Evaluator Function 203
|
||||
FUNCTIONP [object] Evaluator Function 197
|
||||
|
||||
GCD [n1, n2, ..., nm] Numerical Function 129
|
||||
GET [symbol, key] Property Function 77
|
||||
GET-BREAK-CHARS [] Input Function 172
|
||||
GET-MACRO-CHAR [char, flag] Input Function 167
|
||||
GETD [symbol, flag] Definition Function 82
|
||||
GETSET [parameter] Miscellaneous Function 268
|
||||
|
||||
*HIGH-INTENSITY*: NIL Screen Control var. 265
|
||||
|
||||
IDENTITY [object] Control Function 219
|
||||
IF [testform, thenform, elseform] Control Special form 220
|
||||
*IGNORE-CASE*: NIL Input Control var. 173
|
||||
INCF [place, n] Numerical Macro 128
|
||||
INCQ [symbol, n] Numerical Special form 127
|
||||
INPUTFILE [filename] Input Function 158
|
||||
INSERT-LINES [n] Screen Function 261
|
||||
INTEGER-LENGTH [n] Numerical Function 151
|
||||
INTEGERP [object] Recognizer Function 55
|
||||
INTERRUPT [n] Hardware Function 254
|
||||
INTERSECTION [list1, list2, test] Constructor Function 34
|
||||
ISQRT [n] Numerical Function 135
|
||||
|
||||
LAMBDA Definition Keyword 82
|
||||
LAST [list] Selector Function 8
|
||||
LCM [n1, ..., nm] Numerical Function 131
|
||||
LCONC [dotted-pair, list] Modifier Function 50
|
||||
LDIFF [list, tail] Constructor Function 25
|
||||
LENGTH [object] Selector Function 10
|
||||
LET [letlist, form1, ... formn] Control Macro 222
|
||||
LET* [letlist, form1, ... formn]Control Macro 222
|
||||
LINELENGTH [n] Output Function 189
|
||||
LINELENGTH: 'LINELENGTH Output Control var. 190
|
||||
LIST [obj1, ..., objn] Constructor Function 19
|
||||
LIST* [obj1, ..., objn] Constructor Function 19
|
||||
LIST-LENGTH [object] Selector Function 10
|
||||
LISTEN [] Input Function 161
|
||||
LISTP [object] Recognizer Function 58
|
||||
LN [n] Numerical Function 134
|
||||
LOAD [filename] Environment Function 239
|
||||
LOCATION [object] Hardware Function 252
|
||||
LOG [n, base] Numerical Function 134
|
||||
LOGAND [n1, ..., nm] Numerical Function 149
|
||||
LOGIOR [n1, ..., nm] Numerical Function 149
|
||||
LOGNOT [n] Numerical Function 148
|
||||
LOGXOR [n1, ..., nm] Numerical Function 149
|
||||
LOOP [form1, ..., formn] Control Special form 217
|
||||
LOWER-CASE-P [symbol] Character Function 89
|
||||
|
||||
MACRO Definition Keyword 82
|
||||
MACRO-FUNCTION [symbol] Evaluator Function 205
|
||||
MACRO-FUNCTION-P [symbol] Evaluator Function 196
|
||||
MACROEXPAND [form] Evaluator Function 206
|
||||
MACROEXPAND-1 [form] Evaluator Function 206
|
||||
MAKE-LIST [n, object, list] Constructor Function 20
|
||||
MAKE-RANDOM-STATE [state] Numerical Function 153
|
||||
MAKE-WINDOW [row, col, rows, cols] Screen Function 262
|
||||
MAPC [function, list1, ...] Evaluator Function 208
|
||||
MAPCAN [function, list1, ...] Evaluator Function 210
|
||||
MAPCAR [function, list1, ...] Evaluator Function 209
|
||||
MAPCON [function, list1, ...] Evaluator Function 210
|
||||
MAPL [function, list1, ...] Evaluator Function 208
|
||||
MAPLIST [function, list1, ...] Evaluator Function 209
|
||||
MAX [n1, ..., nm] Numerical Function 121
|
||||
MEMBER [object, list, test] Searcher Function 13
|
||||
MEMBER-IF [test, list] Searcher Function 13
|
||||
MEMORY [address, value, flag] Hardware Function 247
|
||||
MERGE [list1, list2, test] Modifier Function 52
|
||||
MIN [n1, ..., nm] Numerical Function 121
|
||||
MINUSP [object] Numerical Function 113
|
||||
MISMATCH [list1, list2, test] Searcher Function 12
|
||||
MOD [n, m] Numerical Function 146
|
||||
MOVD [symbol1, symbol2] Definition Function 84
|
||||
|
||||
NBUTLAST [list, n] Modifier Function 42
|
||||
NCONC [list1, ..., listn] Modifier Function 41
|
||||
NEQ [obj1, obj2] Comparator Function 60
|
||||
NEQL [obj1, obj2] Comparator Function 61
|
||||
NIL Evaluator Constant 197
|
||||
NINTH [list] Selector Function 7
|
||||
NLAMBDA Definition Keyword 82
|
||||
NO-EVAL-FUNCTION-P [symbol] Evaluator Function 196
|
||||
NOT [object] Logical Function 65
|
||||
NOTANY [test, list1, ...] Evaluator Function 211
|
||||
NOTEVERY [test, list1, ...] Evaluator Function 212
|
||||
NRECONC [list, object] Modifier Function 43
|
||||
NREVERSE [list, object] Modifier Function 43
|
||||
NSUBLIS [alist, object, test] Modifier Function 48
|
||||
NSUBST [new, old, object, test] Modifier Function 47
|
||||
NSUBST-IF [new, test, object] Modifier Function 47
|
||||
NSUBSTITUTE [new, old, list, test] Modifier Function 46
|
||||
NSUBSTITUTE-IF [new, test, list] Modifier Function 46
|
||||
NTH [n, list] Selector Function 9
|
||||
NTHCDR [n, list] Selector Function 9
|
||||
NULL [object] Recognizer Function 57
|
||||
NUMBERP [object] Recognizer Function 55
|
||||
NUMERATOR [n] Numerical Function 141
|
||||
NUMERIC-CHAR-P [symbol] Character Function 90
|
||||
|
||||
OBLIST [] Constructor Function 37
|
||||
ODDP [object] Numerical Function 114
|
||||
OPENFILES [] Input Function 158
|
||||
OR [form1, ..., formn] Logical Special form 67
|
||||
ORDERP [object1, object2] Comparator Function 64
|
||||
OUTPUTFILE [filename] Output Function 179
|
||||
|
||||
PACK [list] String Function 98
|
||||
PACK* [atom1, ..., atomn] String Function 98
|
||||
PAIRLIS [keys, objects, alist] Constructor Function 36
|
||||
PEEK-CHAR [flag] Input Function 164
|
||||
PI [] Numerical Function 138
|
||||
PLUSP [object] Numerical Function 113
|
||||
POP [symbol] Assignment Special form 73
|
||||
PORTIO [port, value, flag] Hardware Function 251
|
||||
POSITION [object, list, test] Searcher Function 15
|
||||
POSITION-IF [test, list] Searcher Function 15
|
||||
PRECISION [n] Numerical Function 109
|
||||
PRIN1 [object] Output Function 183
|
||||
PRINC [object] Output Function 184
|
||||
PRINT [object] Output Function 184
|
||||
*PRINT-BASE*: 10 Output Control var. 191
|
||||
*PRINT-DOWNCASE*: NIL Output Control var. 190
|
||||
*PRINT-ESCAPE*: T Output Control var. 191
|
||||
PRINT-LENGTH [atom] String Function 107
|
||||
*PRINT-POINT*: 7 Output Control var. 192
|
||||
*PRINTER-ECHO*: NIL Output Control var. 193
|
||||
PROG1 [form1, ... formn] Control Special form 218
|
||||
PROG2 [form1, ... formn] Control Macro 218
|
||||
PROGN [form1, ... formn] Control Special form 216
|
||||
PSETQ [symbol1, form1, ...] Assignment Special form 71
|
||||
PUSH [form, symbol] Assignment Special form 74
|
||||
PUSHNEW [form, symbol, test] Assignment Macro 74
|
||||
PUT [symbol, key, object] Property Function 76
|
||||
PUTD [symbol, definition] Definition Function 83
|
||||
PUTD: 'PUTD Definition Control var. 86
|
||||
|
||||
QUOTE [object] Control Special form 215
|
||||
|
||||
RANDOM [n, state] Numerical Function 152
|
||||
*RANDOM-STATE* Numerical Control var. 153
|
||||
RANDOM-STATE-P [object] Numerical Function 154
|
||||
RASSOC [key, alist, test] Searcher Function 17
|
||||
RASSOC-IF [test, alist] Searcher Function 17
|
||||
RATIONALP [object] Recognizer Function 55
|
||||
RATOM [] Input Function 171
|
||||
RDS [filename] Input Function 156
|
||||
READ [] Input Function 166
|
||||
*READ-BASE*: 10 Input Control var. 173
|
||||
READ-BYTE [] Input Function 165
|
||||
READ-CHAR [peek-flag] Input Function 162
|
||||
READ-CHAR: 'READ-CHAR Input Control var. 173
|
||||
READ-LINE [] Input Function 165
|
||||
*READ-UPCASE*: T Input Control var. 174
|
||||
READPTR [n] Input Function 159
|
||||
RECLAIM [] Memory Function 232
|
||||
REDUCE [function, list, init] Evaluator Function 213
|
||||
REGISTER [n, m] Hardware Function 253
|
||||
REM [n, m] Numerical Function 146
|
||||
REMD [symbol] Definition Function 85
|
||||
REMFLAG [symbol, attribute] Flag Function 80
|
||||
REMOVE [item, list, test] Constructor Function 28
|
||||
REMOVE-DUPLICATES [list, test] Constructor Function 29
|
||||
REMOVE-IF [test, list] Constructor Function 28
|
||||
REMPROP [symbol, key] Property Function 78
|
||||
REPLACE [list1, list2] Modifier Function 40
|
||||
REST [list] Selector Function 7
|
||||
RESTART [] Control Function 230
|
||||
RETURN [object] Control Function 229
|
||||
REVAPPEND [list, object] Constructor Function 27
|
||||
REVERSE [list, object] Constructor Function 27
|
||||
ROUND [n, m] Numerical Function 145
|
||||
ROW [] Screen Function 259
|
||||
RPLACA [obj1, obj2] Modifier Function 38
|
||||
RPLACD [obj1, obj2] Modifier Function 39
|
||||
|
||||
SAVE [filename] Environment Function 237
|
||||
SECOND [list] Selector Function 7
|
||||
SET [symbol, object] Assignment Function 69
|
||||
SET-BREAK-CHARS [list, flag] Input Function 172
|
||||
SET-CURSOR [row, column] Screen Function 259
|
||||
SET-DIFFERENCE [list1, list2, test] Constructor Function 35
|
||||
SET-MACRO-CHAR [char, defn, flg] Input Function 167
|
||||
SETF [place1, form1, ... ] Assignment Macro 72
|
||||
SETQ [symbol1, form1, ...] Assignment Special form 70
|
||||
SEVENTH [list] Selector Function 7
|
||||
SHIFT [n, m] Numerical Function 150
|
||||
SIGNUM [n] Numerical Function 140
|
||||
SIN [n] Numerical Function 136
|
||||
SIXTH [list] Selector Function 7
|
||||
SNAPSHOT [address, atom] Hardware Function 256
|
||||
SOME [test, list1, ... listn] Evaluator Function 211
|
||||
SORT [list, test] Modifier Function 53
|
||||
SPACES [n] Output Function 186
|
||||
SPECIAL Definition Keyword 82
|
||||
SPECIAL-FORM-P [symbol] Evaluator Function 196
|
||||
SPLIT [list] Modifier Function 51
|
||||
SQRT [n] Numerical Function 135
|
||||
STABLE-SORT [list, test] Modifier Function 53
|
||||
STACK-LIST [] Constructor Function 37
|
||||
STRING-CAPITALIZE [atom] String Function 105
|
||||
STRING-DOWNCASE [atom] String Function 105
|
||||
STRING-EQUAL [atom1, atom2] String Macro 101
|
||||
STRING-GREATERP [atom1, atom2] String Macro 103
|
||||
STRING-LEFT-TRIM [chars, atom] String Function 104
|
||||
STRING-LESSP [atom1, atom2] String Macro 103
|
||||
STRING-NOT-EQUAL [atm1, atm2] String Macro 103
|
||||
STRING-NOT-GREATERP [atm1, atm2] String Macro 103
|
||||
STRING-NOT-LESSP [atm1, atm2] String Macro 103
|
||||
STRING-RIGHT-TRIM [chars, atom] String Function 104
|
||||
STRING-TRIM [chars, atom] String Function 104
|
||||
STRING-UPCASE [atom] String Function 105
|
||||
STRING= [atom1, atom2, flag] String Function 101
|
||||
STRING< [atom1, atom2, flag] String Function 102
|
||||
STRING> [atom1, atom2, flag] String Function 102
|
||||
STRING<= [atom1, atom2, flag] String Function 102
|
||||
STRING>= [atom1, atom2, flag] String Function 102
|
||||
STRING/= [atom1, atom2, flag] String Function 102
|
||||
STRINGP [object] Recognizer Function 54
|
||||
SUB1 [n] Numerical Function 126
|
||||
SUBLIS [alist, object, test] Constructor Function 32
|
||||
SUBLIST [list, n, m] Constructor Function 24
|
||||
SUBSETP [list1, list2, test] Comparator Function 63
|
||||
SUBST [new, old, object, test] Constructor Function 31
|
||||
SUBST-IF [new, test, object] Constructor Function 31
|
||||
SUBSTITUTE [new, old, list, test] Constructor Function 30
|
||||
SUBSTITUTE-IF [new, test, list] Constructor Function 30
|
||||
SUBSTRING [atom, n, m] String Function 99
|
||||
SYMBOL-FUNCTION [symbol] Evaluator Function 198
|
||||
SYMBOL-PLIST [symbol] Evaluator Function 198
|
||||
SYMBOL-VALUE [symbol] Evaluator Function 198
|
||||
SYMBOLP [object] Recognizer Function 54
|
||||
SYSTEM [n] Control Function 230
|
||||
|
||||
TAILP [list1, list2] Comparator Function 63
|
||||
TAN [n] Numerical Function 136
|
||||
TCONC [dotted-pair, object] Modifier Function 49
|
||||
TENTH [list] Selector Function 7
|
||||
TERPRI [n] Output Function 185
|
||||
THIRD [list] Selector Function 7
|
||||
THROW [label, object] Control Function 228
|
||||
TIME [flag] Miscellaneous Function 267
|
||||
TONE [frequency, duration] Miscellaneous Function 266
|
||||
TREE-EQUAL [object1, object2, test] Comparator Function 62
|
||||
TRUNCATE [n, m] Numerical Function 144
|
||||
|
||||
UNDEFINED [symbol, form1, ...] Evaluator Function 204
|
||||
UNDERFLOW [n] Numerical Function 111
|
||||
UNION [list1, list2, test] Constructor Function 34
|
||||
UNLESS [testform, form1, ... formn] Control Macro 220
|
||||
UNPACK [atom] String Function 97
|
||||
UNREAD-CHAR [] Input Function 163
|
||||
UNWIND-PROTECT [form1, form2, ...] Control Special form 227
|
||||
UPPER-CASE-P [symbol] Character Function 89
|
||||
|
||||
WHEN [testform, form1, ... formn] Control Macro 220
|
||||
WRITE-BYTE [n] Output Function 188
|
||||
WRITE-LINE [symbol] Output Function 187
|
||||
WRITE-STRING [symbol] Output Function 187
|
||||
WRITEPTR [n] Output Function 180
|
||||
WRS [filename, reopen-flag] Output Function 176
|
||||
|
||||
Y-OR-N-P [message] User interface Function 246
|
||||
YES-OR-NO-P [message] User interface Function 246
|
||||
|
||||
ZEROP [object] Numerical Function 112
|
||||
+ [n1, ..., nm] Numerical Function 122
|
||||
- [n1, ..., nm] Numerical Function 123
|
||||
* [n1, ..., nm] Numerical Function 124
|
||||
/ [n1, ..., nm] Numerical Function 125
|
||||
|
||||
= [n1, ..., nm] Numerical Function 115
|
||||
/= [n1, ..., nm] Numerical Function 116
|
||||
< [n1, ..., nm] Numerical Function 117
|
||||
> [n1, ..., nm] Numerical Function 118
|
||||
<= [n1, ..., nm] Numerical Function 119
|
||||
>= [n1, ..., nm] Numerical Function 120
|
||||
|
||||
\ back slash Input Escape char. 166
|
||||
| vertical bar Input Escape char. 166
|
||||
|
||||
( left parenthesis Input Macro char. 168
|
||||
) right parenthesis Input Macro char. 168
|
||||
] right square bracket Input Macro char. 168
|
||||
, comma Input Macro char. 169
|
||||
' single quote Input Macro char. 169
|
||||
" double quote Input Macro char. 170
|
||||
; semicolon Input Macro char. 169
|
||||
|
||||
++ User interface Variable 241
|
||||
+++ User interface Variable 241
|
||||
** User interface Variable 241
|
||||
*** User interface Variable 241
|
||||
|
||||
714
Microsoft muLISP-86 v51/INTERLIS.LSP
Normal file
714
Microsoft muLISP-86 v51/INTERLIS.LSP
Normal file
@ -0,0 +1,714 @@
|
||||
;File: INTERLIS.LSP 12/27/85 Soft Warehouse, Inc.
|
||||
|
||||
|
||||
; Interlisp Compatiblity File
|
||||
|
||||
;References in this file are to the 1978 edition of the Interlisp Reference
|
||||
;Manual, by Warren Teitelman, published by the Xerox Palo Alto Research
|
||||
;Center and Bolt, Beranek & Newman. Each function definition is preceded
|
||||
;by a brief description of its affect and value. See the Interlisp
|
||||
;Reference Manual for a more complete description of the function.
|
||||
|
||||
|
||||
|
||||
; Section 5: Primitive Functions and Predicates
|
||||
|
||||
;RPLNODE [object1, object2, object3] replaces the car of <object1>
|
||||
;with <object2> and the cdr of <object1> with <object3>.
|
||||
|
||||
(DEFUN RPLNODE (OBJ1 OBJ2 OBJ3)
|
||||
(RPLACD (RPLACA OBJ1 OBJ2) OBJ3) )
|
||||
|
||||
|
||||
;RPLNODE2 [object1, object2] replaces the car of <object1> with the
|
||||
;car of <object2> and the cdr of <object1> with the cdr of <object2>.
|
||||
|
||||
(DEFUN RPLNODE2 (OBJ1 OBJ2)
|
||||
(RPLACD (RPLACA OBJ1 (CAR OBJ2)) (CDR OBJ2)) )
|
||||
|
||||
|
||||
;KWOTE [object] returns an expression that when evaluated is <object>.
|
||||
|
||||
(DEFUN KWOTE (OBJ)
|
||||
((OR (NULL OBJ) (NUMBERP OBJ)) OBJ)
|
||||
(LIST 'QUOTE OBJ) )
|
||||
|
||||
|
||||
;SELECTQ [object, clause1, clause2, ..., default] based on <object>,
|
||||
;selects a clause list to be sequentially evaluated.
|
||||
|
||||
(DEFUN SELECTQ (NLAMBDA LST$
|
||||
(SELECTQ-AUX (EVAL (CAR LST$)) (CDR LST$)) ))
|
||||
|
||||
(DEFUN SELECTQ-AUX (OBJ LST)
|
||||
((NULL LST) NIL)
|
||||
(LOOP
|
||||
((NULL (CDR LST))
|
||||
(EVAL (CAR LST)) )
|
||||
((OR (EQ OBJ (CAAR LST))
|
||||
(AND (NOT (ATOM (CAAR LST))) (MEMBER OBJ (CAAR LST))) )
|
||||
(SETQ LST (CDAR LST))
|
||||
(LOOP
|
||||
((NULL (CDR LST))
|
||||
(EVAL (CAR LST)) )
|
||||
(EVAL (POP LST)) ) )
|
||||
(POP LST) ) )
|
||||
|
||||
|
||||
;SETQQ [name, expression] a no-eval function that sets <name> to
|
||||
;<expression>.
|
||||
|
||||
(DEFUN SETQQ (NLAMBDA (NAM$ EXP$)
|
||||
(SET NAM$ EXP$)
|
||||
EXP$ ))
|
||||
|
||||
|
||||
(MOVD 'NAME 'LITATOM) ;Literal atom predicate
|
||||
|
||||
(MOVD 'ATOM 'NLISTP) ;No list predicate
|
||||
|
||||
(DEFUN NILL NIL ;Returns NIL
|
||||
NIL )
|
||||
|
||||
(MOVD 'EQL 'EQP)
|
||||
|
||||
|
||||
;EQLENGTH [list, n] is equivalent to EQ [LENGTH[list], n].
|
||||
|
||||
(DEFUN EQLENGTH (LST NUM)
|
||||
(LOOP
|
||||
((ATOM LST)
|
||||
(ZEROP NUM) )
|
||||
((ZEROP NUM) NIL)
|
||||
(POP LST)
|
||||
(DECQ NUM) ) )
|
||||
|
||||
|
||||
;EQUALN [object1, object2, n] is equivalent to EQUAL except that the
|
||||
;comparison is limited to a depth of <n> levels of recursion. If that
|
||||
;depth is exceeded, '? is returned instead.
|
||||
|
||||
(DEFUN EQUALN (OBJ1 OBJ2 NUM TEMP)
|
||||
(LOOP
|
||||
((ATOM OBJ1)
|
||||
(EQ OBJ1 OBJ2) )
|
||||
((ATOM OBJ2) NIL)
|
||||
((NOT (PLUSP NUM))
|
||||
'? )
|
||||
(DECQ NUM)
|
||||
(SETQ TEMP (EQUALN (POP OBJ1) (POP OBJ2) NUM))
|
||||
((OR (NULL TEMP) (EQ TEMP ?)) TEMP) ) )
|
||||
|
||||
|
||||
(MOVD 'MEMBER 'MEMB)
|
||||
|
||||
|
||||
;EQMEMB [atom, list] returns T if EQ [atom, list] or MEMB [atom, list].
|
||||
;Otherwise, it returns NIL.
|
||||
|
||||
(DEFUN EQMEMB (ATM LST)
|
||||
((EQ ATM LST))
|
||||
(MEMB ATM LST) )
|
||||
|
||||
|
||||
;PUTASSOC [key, object, a-list] replaces the value associated with
|
||||
;<key> on <a-list> with <object>.
|
||||
|
||||
(DEFUN PUTASSOC (KEY OBJ ALST
|
||||
TEMP )
|
||||
(SETQ TEMP (ASSOC KEY ALST))
|
||||
((NULL TEMP)
|
||||
(NCONC ALST (LIST (CONS KEY OBJ)))
|
||||
OBJ )
|
||||
(RPLACD TEMP OBJ)
|
||||
OBJ )
|
||||
|
||||
|
||||
; Section 6: List Manipulation and Concatenation
|
||||
|
||||
;NCONC1 [list, object] adds <object> to the end of <list> by modifying
|
||||
;the last cons of <list>.
|
||||
|
||||
(DEFUN NCONC1 (LST OBJ)
|
||||
(NCONC LST (CONS OBJ)) )
|
||||
|
||||
|
||||
;DOCOLLECT [object, list] efficiently adds <object> to the end of
|
||||
;<list> which is maintained as a pointer to a circular list.
|
||||
|
||||
(DEFUN DOCOLLECT (OBJ LST)
|
||||
((ATOM LST)
|
||||
(CONS OBJ) )
|
||||
((ATOM (CDR LST))
|
||||
((NULL (CAR LST))
|
||||
(RPLACA LST OBJ) )
|
||||
(RPLACD LST (CONS OBJ))
|
||||
(RPLACD (CDR LST) (CDR LST))
|
||||
LST )
|
||||
(RPLACD (CDR LST) (CONS OBJ (CDDR LST)))
|
||||
(RPLACD LST (CDDR LST)) )
|
||||
|
||||
|
||||
;ENDCOLLECT [list, tail] replaces the tail of <list> with <tail> making
|
||||
;<list> no longer circular and returns the resulting list.
|
||||
|
||||
(DEFUN ENDCOLLECT (LST TAIL)
|
||||
((ATOM LST) TAIL)
|
||||
((ATOM (CDR LST))
|
||||
((NULL (CAR LST))
|
||||
((ATOM TAIL) TAIL)
|
||||
(RPLNODE2 LST TAIL) )
|
||||
(RPLACD LST TAIL) )
|
||||
(RPLACD LST (PROG1 (CDDR LST) (RPLACD (CDR LST) TAIL))) )
|
||||
|
||||
|
||||
;ATTACH [object, list] adds <object> to the front of <list> by
|
||||
;modifying the first cons of <list>.
|
||||
|
||||
(DEFUN ATTACH (OBJ LST)
|
||||
((NULL LST)
|
||||
(CONS OBJ) )
|
||||
((ATOM LST) NIL)
|
||||
(RPLACA (RPLACD LST (CONS (CAR LST) (CDR LST))) OBJ) )
|
||||
|
||||
|
||||
;DREMOVE [atom, list] removes <atom> from <list> by modifying <list>.
|
||||
|
||||
(DEFUN DREMOVE (ATM LST
|
||||
TEMP )
|
||||
((ATOM LST) NIL)
|
||||
((EQ ATM (CAR LST))
|
||||
((ATOM (CDR LST)) NIL)
|
||||
(RPLACA LST (CADR LST))
|
||||
(RPLACD LST (CDDR LST))
|
||||
(DREMOVE ATM LST) )
|
||||
(SETQ TEMP LST)
|
||||
(LOOP
|
||||
((ATOM (CDR TEMP)) LST)
|
||||
( ((EQ ATM (CADR TEMP))
|
||||
(RPLACD TEMP (CDDR TEMP)) )
|
||||
(POP TEMP) ) ) )
|
||||
|
||||
|
||||
;MKLIST [object] returns (LIST object) if <object> is a nonNIL atom;
|
||||
;otherwise, it returns <object>.
|
||||
|
||||
(DEFUN MKLIST (OBJ)
|
||||
((NULL OBJ) OBJ)
|
||||
((ATOM OBJ)
|
||||
(CONS OBJ) )
|
||||
OBJ )
|
||||
|
||||
|
||||
;COPY [object] copies <object> down to the atomic level.
|
||||
|
||||
(MOVD 'COPY-TREE 'COPY)
|
||||
|
||||
|
||||
;DREVERSE [list] reverses <list> without consing by modifying <list>.
|
||||
|
||||
(MOVD NREVERSE DREVERSE)
|
||||
|
||||
|
||||
;DSUBST [new, old, object] substitutes <new> for all sub-expressions
|
||||
;EQUAL to <old> in <object> without consing.
|
||||
|
||||
(DEFUN DSUBST (NEW OLD OBJ)
|
||||
((EQUAL OLD OBJ) NEW)
|
||||
((ATOM OBJ) OBJ)
|
||||
(RPLACD (RPLACA OBJ (DSUBST NEW OLD (CAR OBJ)))
|
||||
(DSUBST NEW OLD (CDR OBJ))) )
|
||||
|
||||
|
||||
;SUBLIS [a-list, object, flag] substitutes in <object> for each key in
|
||||
;<a-list> the associated value. If <flag> is NIL, a new structure is
|
||||
;created only if necessary. If <flag> is nonNIL, new structure is always
|
||||
;created.
|
||||
|
||||
(DEFUN SUBLIS (ALST OBJ FLG
|
||||
TEMP1 TEMP2 )
|
||||
((ATOM OBJ)
|
||||
(SETQ TEMP1 (ASSOC OBJ ALST))
|
||||
((NULL TEMP1) OBJ)
|
||||
(CDR TEMP1) )
|
||||
(SETQ TEMP1 (SUBLIS ALST (CAR OBJ) FLG)
|
||||
TEMP2 (SUBLIS ALST (CDR OBJ) FLG))
|
||||
((AND (NOT FLG) (EQ (CAR OBJ) TEMP1) (EQ (CDR OBJ) TEMP2)) OBJ)
|
||||
(CONS TEMP1 TEMP2) )
|
||||
|
||||
|
||||
;NLEFT [list, n, tail] returns <n> more elements from the end of <list>
|
||||
;than <tail>. <tail> should be NIL or a tail of <list>.
|
||||
|
||||
(DEFUN NLEFT (LST NUM TAIL)
|
||||
((OR (NULL LST) (EQ LST TAIL))
|
||||
((OR (NOT (NUMBERP NUM)) (ZEROP NUM)) LST)
|
||||
1 )
|
||||
(SETQ TAIL (NLEFT (CDR LST) NUM TAIL))
|
||||
((NUMBERP TAIL)
|
||||
((EQ TAIL NUM) LST)
|
||||
(ADD1 TAIL) )
|
||||
TAIL )
|
||||
|
||||
|
||||
;LASTN [list, n] returns CONS[list1,list2] where <list2> is the last
|
||||
;<n> elements of <list> and <list1> is the remaining elements of <list>.
|
||||
|
||||
(DEFUN LASTN (LST NUM
|
||||
TAIL )
|
||||
((NULL (SETQ TAIL (NLEFT LST NUM))) NIL)
|
||||
(CONS (LDIFF LST TAIL) TAIL) )
|
||||
|
||||
|
||||
;EQLENGTH [list, n] was defined earlier.
|
||||
|
||||
|
||||
;COUNTDOWN [object, n] returns the larger of 0 or <n> minus the number
|
||||
;of nodes in <object>.
|
||||
|
||||
(DEFUN COUNTDOWN (OBJ NUM)
|
||||
((ZEROP NUM) NUM)
|
||||
((PLUSP NUM)
|
||||
(LOOP
|
||||
((ATOM OBJ) NUM)
|
||||
(SETQ NUM (COUNTDOWN (POP OBJ) (SUB1 NUM)))
|
||||
((ZEROP NUM) NUM) ) ) )
|
||||
|
||||
|
||||
;LDIFF [list1, tail, list2] returns a list of the elements of <list1>
|
||||
;up to <tail> nconced onto <list2>.
|
||||
|
||||
(DEFUN LDIFF (LST1 TAIL LST2)
|
||||
((ATOM TAIL)
|
||||
(NCONC LST2 LST1) )
|
||||
(NCONC LST2 (LDIFF-AUX LST1)) )
|
||||
|
||||
(DEFUN LDIFF-AUX (LST)
|
||||
((OR (ATOM LST) (EQ LST TAIL)) NIL)
|
||||
(CONS (CAR LST) (LDIFF-AUX (CDR LST))) )
|
||||
|
||||
|
||||
;LDIFFERENCE [list1, list2] returns a list of the elements in <list1>
|
||||
;that are not a MEMBER of <list2>.
|
||||
|
||||
(MOVD 'SET-DIFFERENCE 'LDIFFERENCE)
|
||||
|
||||
|
||||
;ALPHORDER [atom1, atom2] a predicate for alphabetizing atoms. Numbers
|
||||
;come before names and are sorted numerically.
|
||||
|
||||
(MOVD 'STRING< 'ALPHORDER)
|
||||
|
||||
|
||||
; Section 7: Property Lists and Hash Links
|
||||
|
||||
;In muLISP, property lists are association lists of the form:
|
||||
; ((KEY.VALUE) (KEY.VALUE) ... (KEY.VALUE)).
|
||||
|
||||
;In Interlisp, property lists are lists of the form:
|
||||
; (KEY VALUE KEY VALUE ... KEY VALUE).
|
||||
|
||||
|
||||
;GETPROPLIST [name] returns <name>'s p-list (property list).
|
||||
|
||||
(DEFUN GETPROPLIST (NAM)
|
||||
((NAME NAM)
|
||||
(CDR NAM) ) )
|
||||
|
||||
|
||||
;SETPROPLIST [name, list] replaces the p-list of <name> with <list>
|
||||
;and returns <list>.
|
||||
|
||||
(DEFUN SETPROPLIST (NAM LST)
|
||||
((AND NAM (NAME NAM))
|
||||
(RPLACD NAM LST)
|
||||
LST ) )
|
||||
|
||||
|
||||
;GETPROP [name, key] returns the property value on <name>'s p-list under
|
||||
;the indicator <key>. NIL is returned if no such property exists.
|
||||
;GETPROP is equivalent to the muLISP function GET.
|
||||
|
||||
(MOVD 'GET 'GETPROP)
|
||||
|
||||
|
||||
;PUTPROP [name, key, object] puts on <name>'s p-list under the indicator
|
||||
;<key> the property value <object>. PUTPROP is equivalent to the muLISP
|
||||
;function PUT.
|
||||
|
||||
(MOVD 'PUT 'PUTPROP)
|
||||
|
||||
|
||||
;PUTPROPS [name, key1, object1, ..., keyn, objectn] an NLAMBDA, no-spread
|
||||
;function that puts properties on <name>'s p-list.
|
||||
|
||||
(DEFUN PUTPROPS (NLAMBDA LST$
|
||||
(PUTPROPS-AUX (CAR LST$) (CDR LST$)) ))
|
||||
|
||||
(DEFUN PUTPROPS-AUX (NAM LST)
|
||||
(LOOP
|
||||
((ATOM LST) NAM)
|
||||
(PUT NAM (POP LST) (POP LST)) ) )
|
||||
|
||||
|
||||
;PUTQQ [name, key, object] a no-eval function that puts on <name>'s
|
||||
;p-list under <key> the property value <object>. If a PUTQQ command is
|
||||
;issued from the muSTAR editor, the property is flagged for saving,
|
||||
;making PUTQQ roughly equivalent to the Interlisp SAVEPUT function.
|
||||
|
||||
|
||||
;ADDPROP [name, key, object, flag] nconcs <object> to the <key>
|
||||
;property on <name>'s p-list if <flag> is NIL. If <flag> is nonNIL,
|
||||
;<object> is consed onto the front of the property.
|
||||
|
||||
(DEFUN ADDPROP (NAM KEY OBJ FLG
|
||||
TEMP )
|
||||
(SETQ TEMP (ASSOC KEY (CDR NAM)))
|
||||
((NULL TEMP)
|
||||
(PUTPROP NAM KEY (LIST OBJ)) )
|
||||
((NULL FLG)
|
||||
(CDR (NCONC TEMP (LIST OBJ))) )
|
||||
(CDR (RPLACD TEMP (CONS OBJ (CDR TEMP)))) )
|
||||
|
||||
|
||||
;REMPROP [name, key] removes the property <key> from <name>'s p-list.
|
||||
;REMPROP is a primitively defined muLISP function.
|
||||
|
||||
|
||||
;REMPROPLIST [name, list] removes from <name>'s p-list the properties
|
||||
;whose keys are members of <list>.
|
||||
|
||||
(DEFUN REMPROPLIST (NAM LST)
|
||||
(LOOP
|
||||
((ATOM LST) NIL)
|
||||
(REMPROP NAM (POP LST)) ) )
|
||||
|
||||
|
||||
;CHANGEPROP [name, key1, key2] replaces the key for the <key1> property
|
||||
;on <name>'s p-list with <key2>.
|
||||
|
||||
(DEFUN CHANGEPROP (NAM KEY1 KEY2)
|
||||
((SETQ KEY1 (ASSOC KEY1 (CDR NAM)))
|
||||
(RPLACA KEY1 KEY2)
|
||||
NAM ) )
|
||||
|
||||
|
||||
;PROPNAMES [name] returns a list of the keys on <name>'s p-list.
|
||||
|
||||
(DEFUN PROPNAMES (NAM
|
||||
LST )
|
||||
(LOOP
|
||||
(SETQ NAM (CDR NAM))
|
||||
((NULL NAM)
|
||||
(REVERSE LST) )
|
||||
( ((ATOM (CAR NAM)))
|
||||
(PUSH (CAAR NAM) LST) ) ) )
|
||||
|
||||
|
||||
;GETLIS [name, list] returns <name>'s p-list beginning with the first
|
||||
;key that is a member of <list>.
|
||||
|
||||
(DEFUN GETLIS (NAM LST)
|
||||
((NULL NAM) NIL)
|
||||
( ((NAME NAM)
|
||||
(SETQ NAM (CDR NAM)) ) )
|
||||
(LOOP
|
||||
((NULL NAM) NIL)
|
||||
((AND (NOT (ATOM (CAR NAM))) (MEMBER (CAAR NAM) LST))
|
||||
NAM )
|
||||
(POP NAM) ) )
|
||||
|
||||
|
||||
;DEFLIST [list, key] for each element of <list>, puts on the p-list of
|
||||
;the car of the element under the indicator <key> the cadr of the element.
|
||||
|
||||
(DEFUN DEFLIST (LST KEY)
|
||||
(LOOP
|
||||
((NULL LST) NIL)
|
||||
(PUTPROP (CAAR LST) KEY (CADAR LST))
|
||||
(POP LST) ) )
|
||||
|
||||
|
||||
|
||||
; Section 8: Function Definition and Evaluation
|
||||
|
||||
;DEFINE [definition-list] defines the functions on <definition-list>
|
||||
;where each element of <definition-list> is a list of the form:
|
||||
; (name (LAMBDA (arg-list) body)),
|
||||
;or of the form:
|
||||
; (name (arg-list) body).
|
||||
|
||||
(DEFUN DEFINE (LST
|
||||
OBJ )
|
||||
(LOOP
|
||||
((ATOM LST) NIL)
|
||||
(SETQ OBJ (POP LST))
|
||||
( ((OR (ATOM OBJ) (NOT (NAME (CAR OBJ)))))
|
||||
((OR (EQ (CAADR OBJ) 'LAMBDA) (EQ (CAADR OBJ) 'NLAMBDA))
|
||||
(PUTD (CAR OBJ) (CADR OBJ)) )
|
||||
(PUTD (CAR OBJ) (CONS 'LAMBDA (CDR OBJ))) ) ) )
|
||||
|
||||
|
||||
;DEFINEQ [list1, list2, ..., listn] a no-eval function that applies
|
||||
;DEFINE to each element of <list1> through <listn>.
|
||||
|
||||
(DEFUN DEFINEQ (NLAMBDA LST$
|
||||
(DEFINE LST$) ))
|
||||
|
||||
|
||||
;BOUNDP [name] returns T if <name> currently has a value other than
|
||||
;itself or NOBIND. Otherwise it returns NIL.
|
||||
|
||||
(DEFUN BOUNDP (NAM)
|
||||
(NOT (OR (EQ NAM (CAR NAM)) (EQ (CAR NAM) 'NOBIND))) )
|
||||
|
||||
|
||||
;APPLY* [function, arg1, arg2, ..., argn] applies <function> to the
|
||||
;arguments <arg1> through <argn>. The <function> argument in a call
|
||||
;to APPLY* is not evaluated.
|
||||
|
||||
(DEFMACRO APPLY* (FUNC . ARGS)
|
||||
(CONS* 'FUNCALL (LIST 'QUOTE FUNC) ARGS) )
|
||||
|
||||
|
||||
;RPT [n, expression] evaluates <expression> <n> times.
|
||||
|
||||
(DEFUN RPT (NUM EXP)
|
||||
((PLUSP NUM)
|
||||
(LOOP
|
||||
((EQ NUM 1)
|
||||
(EVAL EXP) )
|
||||
(EVAL EXP)
|
||||
(DECQ NUM) ) ) )
|
||||
|
||||
|
||||
;RPTQ [n, expression] is equivalent to RPT except <expression> is not
|
||||
;evaluated before the function is called.
|
||||
|
||||
(DEFUN RPTQ (NLAMBDA (NUM$ EXP$)
|
||||
(RPT (EVAL NUM$) EXP$) ))
|
||||
|
||||
|
||||
|
||||
; Section 11: Functions with Functional Arguments
|
||||
|
||||
|
||||
;Since the map functions in this section conflict with the primitive muLISP
|
||||
;map functions, their names are preceeded with an I standing for Interlisp.
|
||||
|
||||
;IMAP [list, function1, function2] if <function2> is NIL, it applies
|
||||
;<function1> to successive cdrs of <list> beginning with the whole list.
|
||||
;If <function2> is nonNIL, it uses <function2> instead of cdr to step
|
||||
;through <list>.
|
||||
|
||||
(DEFUN IMAP (LST FUN1 FUN2)
|
||||
((NULL FUN2)
|
||||
(LOOP
|
||||
((ATOM LST) NIL)
|
||||
(FUNCALL FUN1 LST)
|
||||
(POP LST) ) )
|
||||
(LOOP
|
||||
((ATOM LST) NIL)
|
||||
(FUNCALL FUN1 LST)
|
||||
(SETQ LST (FUNCALL FUN2 LST)) ) )
|
||||
|
||||
|
||||
;IMAPC [list, function1, function2] if <function2> is NIL, it applies
|
||||
;<function1> to successive elements of <list> beginning with the whole
|
||||
;list. If <function2> is nonNIL, it uses <function2> instead of cdr
|
||||
;to step through <list>.
|
||||
|
||||
(DEFUN IMAPC (LST FUN1 FUN2)
|
||||
((NULL FUN2)
|
||||
(LOOP
|
||||
((ATOM LST) NIL)
|
||||
(FUNCALL FUN1 (POP LST)) ) )
|
||||
(LOOP
|
||||
((ATOM LST) NIL)
|
||||
(FUNCALL FUN1 (CAR LST))
|
||||
(SETQ LST (FUNCALL FUN2 LST)) ) )
|
||||
|
||||
|
||||
;IMAPLIST [list, function1, function2] returns a list of the same values
|
||||
;computed by IMAP [list, function1, function2].
|
||||
|
||||
(DEFUN IMAPLIST (LST FUN1 FUN2)
|
||||
((ATOM LST) NIL)
|
||||
((NULL FUN2)
|
||||
(CONS (FUNCALL FUN1 LST) (IMAPLIST (CDR LST) FUN1)) )
|
||||
(CONS (FUNCALL FUN1 LST) (IMAPLIST (FUNCALL FUN2 LST) FUN1 FUN2)) )
|
||||
|
||||
|
||||
;IMAPCAR [list, function1, function2] returns a list of the same values
|
||||
;computed by IMAPC [list, function1, function2].
|
||||
|
||||
(DEFUN IMAPCAR (LST FUN1 FUN2)
|
||||
((ATOM LST) NIL)
|
||||
((NULL FUN2)
|
||||
(CONS (FUNCALL FUN1 (CAR LST)) (IMAPCAR (CDR LST) FUN1)) )
|
||||
(CONS (FUNCALL FUN1 (CAR LST)) (IMAPCAR (FUNCALL FUN2 LST) FUN1 FUN2)) )
|
||||
|
||||
|
||||
;IMAPCON [list, function1, function2] concatenates the values computed
|
||||
;by IMAP [list, function1, function2] using NCONC.
|
||||
|
||||
(DEFUN IMAPCON (LST FUN1 FUN2
|
||||
RSLT ANS )
|
||||
(LOOP
|
||||
((ATOM LST) RSLT)
|
||||
(SETQ RSLT (FUNCALL FUN1 LST))
|
||||
(SETQ LST (COND
|
||||
(FUNCALL FUN2 (FUNCALL FUN2 LST))
|
||||
((CDR LST)) ))
|
||||
((NOT (ATOM RSLT))
|
||||
(SETQ ANS RSLT)
|
||||
(LOOP
|
||||
((ATOM LST) ANS)
|
||||
(SETQ RSLT (LAST RSLT))
|
||||
(RPLACD RSLT (FUNCALL FUN1 LST))
|
||||
(SETQ LST (COND
|
||||
(FUNCALL FUN2 (FUNCALL FUN2 LST))
|
||||
((CDR LST)) )) ) ) ) )
|
||||
|
||||
|
||||
;IMAPCONC [list, function1, function2] concatenates the values computed
|
||||
;by IMAPC [list, function1, function2] using NCONC.
|
||||
|
||||
(DEFUN IMAPCONC (LST FUN1 FUN2
|
||||
RSLT ANS )
|
||||
(LOOP
|
||||
((ATOM LST) RSLT)
|
||||
(SETQ RSLT (FUNCALL FUN1 (CAR LST)))
|
||||
(SETQ LST (COND
|
||||
(FUNCALL FUN2 (FUNCALL FUN2 LST))
|
||||
((CDR LST)) ))
|
||||
((NOT (ATOM RSLT))
|
||||
(SETQ ANS RSLT)
|
||||
(LOOP
|
||||
((ATOM LST) ANS)
|
||||
(SETQ RSLT (LAST RSLT))
|
||||
(RPLACD RSLT (FUNCALL FUN1 (CAR LST)))
|
||||
(SETQ LST (COND
|
||||
(FUNCALL FUN2 (FUNCALL FUN2 LST))
|
||||
((CDR LST)) )) ) ) ) )
|
||||
|
||||
|
||||
;SUBSET [list, function1, function2] applies <function1> to the elements
|
||||
;of <list> and returns a list of the elements for which the results were
|
||||
;nonNIL. If <function2> is nonNIL, it is used for stepping through <list>.
|
||||
|
||||
(DEFUN SUBSET (LST FUN1 FUN2)
|
||||
((ATOM LST) NIL)
|
||||
((FUNCALL FUN1 (CAR LST))
|
||||
(CONS (CAR LST) (SUBSET (COND
|
||||
(FUNCALL FUN2 (FUNCALL FUN2 LST))
|
||||
((CDR LST)) ) FUN1 FUN2)) )
|
||||
(SUBSET (COND
|
||||
(FUNCALL FUN2 (FUNCALL FUN2 LST))
|
||||
((CDR LST)) ) FUN1 FUN2) )
|
||||
|
||||
|
||||
;IMAP2C [list1, list2, function1, function2] if <function2> is NIL, it
|
||||
;applies <function1> to successive elements of <list1> and <list2>. If
|
||||
;<function2> is nonNIL, it uses <function2> instead of cdr to step
|
||||
;through <list>.
|
||||
|
||||
(DEFUN IMAP2C (LST1 LST2 FUN1 FUN2)
|
||||
((NULL FUN2)
|
||||
(LOOP
|
||||
((OR (ATOM LST1) (ATOM LST2)) NIL)
|
||||
(FUNCALL FUN1 (POP LST1) (POP LST2)) ) )
|
||||
(LOOP
|
||||
((OR (ATOM LST1) (ATOM LST2)) NIL)
|
||||
(FUNCALL FUN1 (CAR LST1) (CAR LST2))
|
||||
(SETQ LST1 (FUNCALL FUN2 LST1)
|
||||
LST2 (FUNCALL FUN2 LST2)) ) )
|
||||
|
||||
|
||||
;IMAP2CAR [list1, list2, function1, function2] returns a list of the
|
||||
;same values computed by IMAP2C [list1, list2, function1, function2].
|
||||
|
||||
(DEFUN IMAP2CAR (LST1 LST2 FUN1 FUN2)
|
||||
((OR (ATOM LST1) (ATOM LST2)) NIL)
|
||||
((NULL FUN2)
|
||||
(CONS (FUNCALL FUN1 (CAR LST1) (CAR LST2))
|
||||
(IMAP2CAR (CDR LST1) (CDR LST2) FUN1)) )
|
||||
(CONS (FUNCALL FUN1 (CAR LST1) (CAR LST2))
|
||||
(IMAP2CAR (FUNCALL FUN2 LST1) (FUNCALL FUN2 LST2) FUN1 FUN2)) )
|
||||
|
||||
|
||||
|
||||
; Section 13: Numbers and Arithmetic Functions
|
||||
|
||||
(MOVD 'EQL 'EQN)
|
||||
|
||||
(MOVD 'INTEGERP 'FIXP)
|
||||
|
||||
(MOVD '+ 'PLUS)
|
||||
|
||||
(MOVD '- 'MINUS)
|
||||
(MOVD '- 'DIFFERENCE)
|
||||
|
||||
(MOVD '* 'TIMES)
|
||||
|
||||
(MOVD '/ 'QUOTIENT)
|
||||
|
||||
(MOVD 'REM 'REMAINDER)
|
||||
|
||||
(MOVD '> 'GREATERP)
|
||||
|
||||
(MOVD '< 'LESSP)
|
||||
|
||||
(MOVD '>= 'GEQ)
|
||||
|
||||
(MOVD '<= 'LEQ)
|
||||
|
||||
(MOVD 'LOGIOR 'LOGOR)
|
||||
|
||||
(MOVD 'SHIFT 'RSH)
|
||||
|
||||
|
||||
; Section 14: Input/Output Functions
|
||||
|
||||
(MOVD 'READ-CHAR 'READCH)
|
||||
|
||||
;READLINE [] reads a line from the terminal and returns it as a list.
|
||||
|
||||
(DEFUN READLINE (
|
||||
READ-CHAR RDS )
|
||||
(SETQ READ-CHAR T) ;Set line edit mode
|
||||
(READLINE-AUX (READ-CHAR T)) )
|
||||
|
||||
(DEFUN READLINE-AUX (CHAR)
|
||||
((EQ CHAR (ASCII 13)) NIL)
|
||||
((EQ CHAR '"]") NIL)
|
||||
((EQ CHAR '")") NIL)
|
||||
((EQ CHAR '" ")
|
||||
(SETQ CHAR (READ-CHAR T))
|
||||
((EQ CHAR (ASCII 13))
|
||||
(PRIN1 '"...")
|
||||
(READLINE-AUX (READ-CHAR T)) )
|
||||
(READLINE-AUX CHAR) )
|
||||
(CONS (READ) (READLINE-AUX (READ-CHAR T))) )
|
||||
|
||||
|
||||
;PRIN2 [object] outputs <object> to the COS putting double quote marks
|
||||
;around names containing special characters.
|
||||
|
||||
(DEFUN PRIN2 (OBJ
|
||||
PRIN1 )
|
||||
(SETQ PRIN1)
|
||||
(PRIN1 OBJ) )
|
||||
|
||||
|
||||
;TAB [n, m] outputs <m> spaces (1 if <m> is NIL) and then outputs
|
||||
;enough spaces to move to column <n>.
|
||||
|
||||
(DEFUN TAB (NUM1 NUM2)
|
||||
( ((NULL NUM2)
|
||||
(SPACES 1) )
|
||||
(SPACES NUM2) )
|
||||
(SPACES (DIFFERENCE NUM1 (SPACES))) )
|
||||
|
||||
(RDS)
|
||||
|
||||
195
Microsoft muLISP-86 v51/LESSONS.LSP
Normal file
195
Microsoft muLISP-86 v51/LESSONS.LSP
Normal file
@ -0,0 +1,195 @@
|
||||
; File: LESSONS.LSP (c) 12/29/85 Soft Warehouse, Inc.
|
||||
|
||||
|
||||
; The muLISP Tutorial System Lesson Driver
|
||||
|
||||
(PROGN (WRITE-BYTE 13)
|
||||
(SPACES 2)
|
||||
(TERPRI)
|
||||
(WRITE-STRING "Loading the muLISP Tutorial System: ")
|
||||
(LOOP
|
||||
(EVAL (READ))
|
||||
(PRINC '*) ) )
|
||||
|
||||
(SETQ *LESSON-DRIVE* '||)
|
||||
|
||||
(DEFUN LESSONS (
|
||||
NUM LEFT-COLUMN )
|
||||
(WRS)
|
||||
(SETQ DEFAULT-LESSON 1)
|
||||
(LOOP
|
||||
(RDS)
|
||||
(MOVD 'APP# 'APPEND)
|
||||
(MOVD 'REV# 'REVERSE)
|
||||
(MOVD 'MBR# 'MEMBER)
|
||||
(CLEAR-SCREEN)
|
||||
(SETQ *HIGH-INTENSITY* T)
|
||||
(CENTER "m u L I S P - 8 5")
|
||||
(TERPRI)
|
||||
(CENTER "T U T O R I A L S Y S T E M")
|
||||
(SETQ *HIGH-INTENSITY*)
|
||||
(SETQ LEFT-COLUMN (MAX 0 (- (TRUNCATE (CADDDR (MAKE-WINDOW)) 2) 22)))
|
||||
(SET-CURSOR 5 LEFT-COLUMN)
|
||||
(WRITE-STRING "Lesson Subject")
|
||||
(DISPLAY-MENU SUBJECT-LIST 7 LEFT-COLUMN)
|
||||
(TERPRI 2)
|
||||
(PRINC "When this program asks you to select ")
|
||||
(PRINC "from a list of options and you are not")
|
||||
(PRINC "sure which one to choose, press the ")
|
||||
(PRINC "SPACE BAR for the best default option.")
|
||||
(TERPRI 2)
|
||||
(PRINC "Enter desired lesson number or press \"Q\" ")
|
||||
(PRINC "to quit: ")
|
||||
(SETQ DEFAULT-LESSON (QUERY (LIST* DEFAULT-LESSON 'Q '(1 2 3 4 5 6))))
|
||||
((EQ DEFAULT-LESSON 'Q)
|
||||
(SYSTEM) )
|
||||
(CATCH NIL (READ-LESSON (PACK* 'MULISP DEFAULT-LESSON)))
|
||||
(SETQ DEFAULT-LESSON (IF
|
||||
(EQ DEFAULT-LESSON (LENGTH SUBJECT-LIST))
|
||||
1
|
||||
(ADD1 DEFAULT-LESSON) )) ) )
|
||||
|
||||
(SETQ SUBJECT-LIST '(
|
||||
"Data objects and primitive functions"
|
||||
"Defining functions using recursion"
|
||||
"Symbols, numbers, and conses"
|
||||
"List processing & iterative functions"
|
||||
"Numerical programming techniques"
|
||||
"Implementing turtle graphics routines"
|
||||
))
|
||||
|
||||
(DEFUN READ-LESSON (FILE-NAME
|
||||
EXPN PTRLST BRKFLG)
|
||||
((EQ (RDS (PACK* *LESSON-DRIVE* FILE-NAME ".LES")))
|
||||
((EQ *LESSON-DRIVE* "A:")
|
||||
(TERPRI)
|
||||
(PRINC "Enter the drive that contains the file ")
|
||||
(PRINC (PACK* FILE-NAME ".LES: "))
|
||||
(SETQ *LESSON-DRIVE* (QUERY '(Q A B C D E F G H I J K L M N O P)))
|
||||
((EQ *LESSON-DRIVE* 'Q))
|
||||
(SETQ *LESSON-DRIVE* (PACK* *LESSON-DRIVE* '\:))
|
||||
(READ-LESSON FILE-NAME) )
|
||||
(SETQ *LESSON-DRIVE* "A:")
|
||||
(READ-LESSON FILE-NAME) )
|
||||
(READPTR 0)
|
||||
(LOOP
|
||||
( ((EQ (PEEK-CHAR) '$)
|
||||
(READ-CHAR)
|
||||
(EVAL (READ)) ) )
|
||||
((EQ (READ-LINE) 'CLRSCRN)) )
|
||||
(CLEAR-SCREEN)
|
||||
(PUSH (READPTR) PTRLST)
|
||||
(LOOP
|
||||
((NOT (LISTEN)))
|
||||
( ((EQ (PEEK-CHAR) '$)
|
||||
(SETQ ECHO T)
|
||||
(PRINC (READ-CHAR))
|
||||
(SETQ EXPN (READ)
|
||||
ECHO)
|
||||
((EQ (CAR EXPN) 'DEFUN)
|
||||
(EVAL EXPN) )
|
||||
(TERPRI)
|
||||
(PRINC (EVAL EXPN)) )
|
||||
((EQ (SETQ EXPN (READ-LINE)) 'CONTINUE)
|
||||
( ((EQ (CDR PTRLST))
|
||||
(LBREAK '("Continue lesson" "Abort lesson"))
|
||||
(PUSH (READPTR) PTRLST) )
|
||||
((EQ BRKFLG)
|
||||
((LBREAK '("Continue lesson" "Abort lesson" "Previous screen"))
|
||||
(PUSH (READPTR) PTRLST) )
|
||||
(POP PTRLST)
|
||||
(READPTR (CAR PTRLST)) )
|
||||
((LBREAK '("Continue lesson" "Break lesson" "Abort lesson"
|
||||
"Previous screen"))
|
||||
(PUSH (READPTR) PTRLST) )
|
||||
(POP PTRLST)
|
||||
(READPTR (CAR PTRLST)) )
|
||||
(CLEAR-SCREEN) )
|
||||
((EQ EXPN 'BREAK)
|
||||
(SETQ BRKFLG T)
|
||||
((LBREAK '("Break lesson" "Continue lesson" "Abort lesson"
|
||||
"Previous screen")) )
|
||||
(POP PTRLST)
|
||||
(READPTR (CAR PTRLST))
|
||||
(CLEAR-SCREEN) )
|
||||
((EQ EXPN 'CLRSCRN)
|
||||
(PUSH (READPTR) PTRLST)
|
||||
(CLEAR-SCREEN) )
|
||||
(WRITE-LINE EXPN) ) ) )
|
||||
|
||||
(DEFUN LBREAK (LST
|
||||
CHAR RDS WRS READ-CHAR)
|
||||
(SETQ CHAR (OPTIONS LST))
|
||||
((EQ CHAR 'A)
|
||||
(THROW) )
|
||||
((EQ CHAR 'C))
|
||||
((EQ CHAR 'P) NIL)
|
||||
((EQ CHAR 'B)
|
||||
(SETQ READ-CHAR 'READ-CHAR)
|
||||
(CATCH NIL (DRIVER))
|
||||
(RDS (PACK* *LESSON-DRIVE* FILE-NAME ".LES")) )
|
||||
((EQ CHAR 'S)
|
||||
(SYSTEM) ) )
|
||||
|
||||
(DEFUN OPTIONS (LST1
|
||||
LST2 *PRINT-DOWNCASE* WRS)
|
||||
(WRITE-BYTE 13)
|
||||
(LOOP
|
||||
(PUSH (CAR (UNPACK (PRINC (POP LST1)))) LST2)
|
||||
((EQ LST1))
|
||||
(WRITE-STRING ", ") )
|
||||
(WRITE-STRING " (")
|
||||
(SETQ LST2 (REV# LST2)
|
||||
LST1 LST2)
|
||||
(LOOP
|
||||
(PRINC (POP LST1))
|
||||
((EQ LST1))
|
||||
(PRINC '/) )
|
||||
(WRITE-STRING ")? ")
|
||||
(QUERY LST2) )
|
||||
|
||||
(DEFUN QUERY (LST
|
||||
RDS READ-CHAR CHAR)
|
||||
(CLEAR-INPUT)
|
||||
(LOOP
|
||||
(SETQ CHAR (CHAR-UPCASE (READ-CHAR)))
|
||||
(IF (<= 48 (ASCII CHAR) 57)
|
||||
(SETQ CHAR (- (ASCII CHAR) 48)))
|
||||
((MBR# CHAR LST)
|
||||
(PRINC CHAR)
|
||||
(TERPRI)
|
||||
CHAR )
|
||||
((EQ CHAR '" ")
|
||||
(PRINC (CAR LST))
|
||||
(TERPRI)
|
||||
(CAR LST) )
|
||||
( ((EQ CHAR (ASCII 10)))
|
||||
((EQ BELL))
|
||||
(WRITE-BYTE 7) ) ) )
|
||||
|
||||
(DEFUN DISPLAY-MENU (OPTION-LIST ROW COLUMN
|
||||
NUM )
|
||||
(SETQ NUM 0)
|
||||
(IF (> (CADDDR (MAKE-WINDOW)) 50)
|
||||
(INCQ COLUMN 3) )
|
||||
(LOOP
|
||||
((EQ OPTION-LIST))
|
||||
(SET-CURSOR (+ ROW NUM) COLUMN)
|
||||
(PRINC (INCQ NUM))
|
||||
(SPACES 1)
|
||||
(IF (> (CADDDR (MAKE-WINDOW)) 50) (SPACES 3))
|
||||
(WRITE-LINE (POP OPTION-LIST)) ) )
|
||||
|
||||
(DEFUN CENTER (MSG)
|
||||
(SET-CURSOR (ROW)
|
||||
(TRUNCATE (- (CADDDR (MAKE-WINDOW)) (LENGTH MSG)) 2))
|
||||
(WRITE-LINE MSG) )
|
||||
|
||||
(MOVD 'REVERSE 'REV#)
|
||||
(MOVD 'MEMBER 'MBR#)
|
||||
(MOVD 'APPEND 'APP#)
|
||||
|
||||
(SETQ DRIVER 'LESSONS)
|
||||
|
||||
(RETURN)
|
||||
|
||||
276
Microsoft muLISP-86 v51/METAMIND.LSP
Normal file
276
Microsoft muLISP-86 v51/METAMIND.LSP
Normal file
@ -0,0 +1,276 @@
|
||||
;File: METAMIND.LSP 12/29/85 Soft Warehouse, Inc.
|
||||
|
||||
|
||||
(LOOP (PRIN1 '*) (EVAL (READ)) ((NULL RDS)) )
|
||||
|
||||
(DEFUN METAMIND (
|
||||
KEYLIST HELPMK HELPBR SEED)
|
||||
(CLEAR-SCREEN)
|
||||
(TERPRI)
|
||||
(CENTER "* * * T H E M E T A M I N D G A M E * * *")
|
||||
(TERPRI 2)
|
||||
(CENTER "Break the secret code using pure logic.")
|
||||
(TERPRI 3)
|
||||
(SETQ KEYLIST '(
|
||||
(BLU GRN WHI YEL RED BLK)
|
||||
(RED YEL GRN BLK BLU WHI)
|
||||
(BLK BLU YEL GRN WHI RED)
|
||||
(YEL WHI RED BLK BLU GRN)
|
||||
))
|
||||
(LOOP
|
||||
(PRINC "Please enter a random number between 1 and 100: ")
|
||||
((PLUSP (SETQ SEED (RATOM))))
|
||||
(TERPRI) )
|
||||
(TERPRI)
|
||||
(LOOP
|
||||
(PRINC "Would you like to be the code Maker or Breaker? (M/B) ")
|
||||
( ((EQ (QUERY '(M B)) 'M)
|
||||
(TERPRI)
|
||||
(HELPMK)
|
||||
(CODEBREAKER) )
|
||||
(TERPRI)
|
||||
(HELPBR)
|
||||
(CODEMAKER) )
|
||||
(TERPRI)
|
||||
((NOT (Y-OR-N-P "Do you want to play another round?")))
|
||||
(TERPRI 2) ) )
|
||||
|
||||
(DEFUN HELPMK ()
|
||||
((EVAL HELPMK))
|
||||
(SETQ HELPMK T)
|
||||
(CENTER "So you want to challenge the champ!")
|
||||
(TERPRI 2)
|
||||
(PRINTC "Ok, after I make my guess, you type in the number of blacks")
|
||||
(PRINTC "(i.e. the number of guesses of the right color and right column),")
|
||||
(PRINTC "a space, and then the number of whites (i.e. of the remaining")
|
||||
(PRINTC "non-black guesses, the number of correct colors). Then press")
|
||||
(PRINTC "the <RETURN> key.")
|
||||
(TERPRI) )
|
||||
|
||||
(DEFUN HELPBR (CTR)
|
||||
((EVAL HELPBR))
|
||||
(SETQ HELPBR T)
|
||||
(PRINTC "So you want to out guess me. Let me think of a code")
|
||||
(SETQ CTR 800)
|
||||
(PRIN1 "Hmmm . ")
|
||||
(LOOP
|
||||
((ZEROP CTR))
|
||||
( ((ZEROP (REM CTR 150)) (PRIN1 ". ")) )
|
||||
(DECQ CTR) )
|
||||
(TERPRI 2)
|
||||
(PRINTC "Ok, I have got one, now make a guess by typing in 4 of the")
|
||||
(PRINC "colors in the following list of colors: ")
|
||||
(PRINT (CAR KEYLIST))
|
||||
(TERPRI) )
|
||||
|
||||
|
||||
(DEFUN CODEBREAKER (
|
||||
MOVE GRAPH CTR KEYLST NUM)
|
||||
(SETQ KEYLIST (MAPCAR 'PERMUTE KEYLIST))
|
||||
(SETQ MOVE (FRSTMOV (CAR KEYLIST)))
|
||||
(SETQ GRAPH (NUGRAPH MOVE))
|
||||
(SETQ CTR 1)
|
||||
(LOOP
|
||||
(SPACES (TRUNCATE (- (LINELENGTH) 32) 2))
|
||||
(PRINC "Move: ")
|
||||
(PRINC CTR)
|
||||
(SPACES 3)
|
||||
(MAPC '(LAMBDA (COLOR) (PRIN1 COLOR) (SPACES 2)) MOVE)
|
||||
(SETQ NUM (RATOM))
|
||||
((EQ NUM 4)
|
||||
(CLEAR-INPUT)
|
||||
(TERPRI)
|
||||
(PRINTC "Yea, I did it! And it only took me " CTR " moves.")
|
||||
(TERPRI) )
|
||||
(SETQ GRAPH (MKGRAPH MOVE NUM (RATOM) MOVE NIL GRAPH KEYLIST))
|
||||
(INCQ CTR)
|
||||
(SETQ ERROR NIL)
|
||||
(SETQ KEYLST KEYLIST)
|
||||
(SETQ MOVE (MKMOVE GRAPH (POP KEYLST)))
|
||||
(TERPRI)
|
||||
((EVAL ERROR)
|
||||
(PRINTC "I am afraid you have made a mistake in your counting.")
|
||||
(PRINTC "Let's start over.") ) ) )
|
||||
|
||||
(DEFUN PERMUTE (LST1 LST2 LST3)
|
||||
((NULL LST1)
|
||||
(NCONC LST2 LST3) )
|
||||
((NULL (CDR LST1))
|
||||
(NCONC (CONS (CAR LST1) LST3) LST2) )
|
||||
((NULL (CDDR LST1))
|
||||
(NCONC (PERMUTE (CONS (CAR LST1) LST2))
|
||||
(PERMUTE (CONS (CADR LST1) LST3))) )
|
||||
(PERMUTE (CDDDR LST1) (CONS (CADR LST1) LST3)
|
||||
(LIST* (CADDR LST1) (CAR LST1) LST2)) )
|
||||
|
||||
|
||||
(DEFUN FRSTMOV (KEY)
|
||||
(LIST (CAR KEY) (CADDR KEY) (CAR KEY) (CADDR KEY)) )
|
||||
|
||||
(DEFUN NUGRAPH (MOVE)
|
||||
((NULL MOVE) T)
|
||||
(NUROW (NUGRAPH (CDR MOVE)) (CAR KEYLIST)) )
|
||||
|
||||
(DEFUN NUROW (GRAPH KEY)
|
||||
((NULL KEY) NIL)
|
||||
(CONS GRAPH (NUROW GRAPH (CDR KEY))) )
|
||||
|
||||
(DEFUN MKMOVE (GRAPH KEY)
|
||||
(LOOP
|
||||
((NULL GRAPH)
|
||||
(SETQ ERROR T) NIL)
|
||||
((CAR GRAPH)
|
||||
((ATOM (CAR GRAPH))
|
||||
(LIST (CAR KEY)) )
|
||||
(CONS (CAR KEY) (MKMOVE (CAR GRAPH) (POP KEYLST))) )
|
||||
(POP GRAPH)
|
||||
(POP KEY) ) )
|
||||
|
||||
(DEFUN MKGRAPH (MOVE BLACKS WHITES FREE UNUSED GRAPH KEYLST)
|
||||
((NULL MOVE)
|
||||
((ZEROP BLACKS)
|
||||
(EQ WHITES (INCOMMON FREE UNUSED)) ) )
|
||||
(MKNODE GRAPH (CAR KEYLST)) )
|
||||
|
||||
(DEFUN MKNODE (GRAPH KEY)
|
||||
((NULL KEY) NIL)
|
||||
((NULL (CAR GRAPH))
|
||||
(CONSNIL (MKNODE (CDR GRAPH) (CDR KEY))) )
|
||||
((EQ (CAR MOVE) (CAR KEY))
|
||||
((PLUSP BLACKS)
|
||||
(CONSNULL (MKGRAPH (CDR MOVE) (SUB1 BLACKS) WHITES
|
||||
(REMBER1 (CAR KEY) FREE) UNUSED (CAR GRAPH) (CDR KEYLST))
|
||||
(MKNODE (CDR GRAPH) (CDR KEY))) )
|
||||
(CONSNIL (MKNODE (CDR GRAPH) (CDR KEY))) )
|
||||
(CONSNULL (MKGRAPH (CDR MOVE) BLACKS WHITES FREE
|
||||
(CONS (CAR KEY) UNUSED) (CAR GRAPH) (CDR KEYLST))
|
||||
(MKNODE (CDR GRAPH) (CDR KEY))) )
|
||||
|
||||
|
||||
(DEFUN CODEMAKER (CODE MOVE CTR)
|
||||
(SETQ KEYLIST (MAPCAR 'PERMUTE KEYLIST))
|
||||
(SETQ CODE (MKCODE KEYLIST))
|
||||
(SETQ CTR 1)
|
||||
(LOOP
|
||||
(SPACES (TRUNCATE (- (LINELENGTH) 32) 2))
|
||||
(PRIN1 "Move: ")
|
||||
(PRIN1 CTR)
|
||||
(SPACES 3)
|
||||
((CODEMATCH CODE (READMOVE CODE) 0)
|
||||
(TERPRI)
|
||||
(PRINTC "That took you " CTR (COND
|
||||
((EQ CTR 1) " move.")
|
||||
(" moves.") ) )
|
||||
((< CTR 6)
|
||||
(PRINTC "Hey you're good, let's play again!") )
|
||||
((< CTR 8)
|
||||
(PRINTC "That was a hard one, want to try to improve your score?") )
|
||||
(PRINTC "Better take a break and let me be the code breaker.") )
|
||||
(TERPRI)
|
||||
(INCQ CTR) ) )
|
||||
|
||||
(DEFUN MKCODE (KEYLST)
|
||||
((NULL KEYLST) NIL)
|
||||
(CONS (NTH (RANDOM 4) (CAR KEYLST)) (MKCODE (CDR KEYLST))) )
|
||||
|
||||
(DEFUN CODEMATCH (CODE1 MOVE1 BLACKS CODE2 MOVE2)
|
||||
((NULL CODE1)
|
||||
(SPACES (+ (TRUNCATE (- (LINELENGTH) 32) 2) 28))
|
||||
((EQ (PRIN1 BLACKS) 4))
|
||||
(SPACES 2)
|
||||
(SAMETYPE CODE2 MOVE2 0)
|
||||
NIL )
|
||||
((EQ (CAR CODE1) (CAR MOVE1))
|
||||
(CODEMATCH (CDR CODE1) (CDR MOVE1) (ADD1 BLACKS) CODE2 MOVE2) )
|
||||
(CODEMATCH (CDR CODE1) (CDR MOVE1) BLACKS (CONS (CAR CODE1) CODE2)
|
||||
(CONS (CAR MOVE1) MOVE2)) )
|
||||
|
||||
(DEFUN SAMETYPE (CODE MOVE WHITES)
|
||||
((NULL CODE)
|
||||
(PRINT WHITES) )
|
||||
((MEMBER (CAR CODE) MOVE)
|
||||
(SAMETYPE (CDR CODE) (REMBER1 (CAR CODE) MOVE) (ADD1 WHITES)) )
|
||||
(SAMETYPE (CDR CODE) MOVE WHITES) )
|
||||
|
||||
(DEFUN READMOVE (CODE)
|
||||
((NULL CODE) NIL)
|
||||
(CONS (RATOM) (READMOVE (CDR CODE))) )
|
||||
|
||||
(DEFUN CONSNULL (X Y)
|
||||
((NULL X)
|
||||
((NULL Y) NIL)
|
||||
(CONS NIL Y) )
|
||||
(CONS X Y) )
|
||||
|
||||
(DEFUN CONSNIL (X)
|
||||
((NULL X) NIL)
|
||||
(CONS NIL X) )
|
||||
|
||||
(DEFUN INCOMMON (LST1 LST2
|
||||
TOT )
|
||||
(SETQ TOT 0)
|
||||
(LOOP
|
||||
((OR (NULL LST1) (NULL LST2)) TOT)
|
||||
( ((MEMBER (CAR LST1) LST2)
|
||||
(SETQ LST2 (REMBER1 (CAR LST1) LST2))
|
||||
(INCQ TOT) ) )
|
||||
(POP LST1) ) )
|
||||
|
||||
(DEFUN REMBER1 (X L)
|
||||
((NULL L) NIL)
|
||||
((EQ X (CAR L)) (CDR L))
|
||||
(CONS (CAR L) (REMBER1 X (CDR L))) )
|
||||
|
||||
(DEFUN REPLACE (X Y L)
|
||||
((NULL L) NIL)
|
||||
((EQ X (CAR L))
|
||||
(CONS Y (REPLACE X Y (CDR L))) )
|
||||
(CONS (CAR L) (REPLACE X Y (CDR L))) )
|
||||
|
||||
(DEFUN RANDOM (NUM)
|
||||
(SETQ SEED (REM (+ 2113233 (* SEED 271821)) 9999991))
|
||||
(REM SEED NUM) )
|
||||
|
||||
(DEFUN Y-OR-N-P (MSG
|
||||
CHAR READ-CHAR RDS WRS )
|
||||
( ((NULL MSG))
|
||||
(FRESH-LINE)
|
||||
(WRITE-STRING (PACK* MSG " (Y/N) ")) )
|
||||
(CLEAR-INPUT)
|
||||
(LOOP
|
||||
(SETQ CHAR (CHAR-UPCASE (READ-CHAR)))
|
||||
((EQ CHAR 'Y)
|
||||
(WRITE-LINE CHAR)
|
||||
T )
|
||||
((EQ CHAR 'N)
|
||||
(WRITE-LINE CHAR)
|
||||
NIL )
|
||||
(WRITE-BYTE 7) ) )
|
||||
|
||||
(DEFUN QUERY (LST
|
||||
CHAR RDS )
|
||||
(CLEAR-INPUT)
|
||||
(LOOP
|
||||
(SETQ CHAR (CHAR-UPCASE (READ-KEY)))
|
||||
((MEMBER CHAR LST)
|
||||
(PRINC CHAR)
|
||||
(TERPRI)
|
||||
CHAR )
|
||||
(PRIN1 (ASCII 7)) ) )
|
||||
|
||||
(DEFUN READ-KEY (
|
||||
READ-CHAR RDS)
|
||||
(READ-CHAR) )
|
||||
|
||||
(DEFUN PRINTC LST
|
||||
(PRINC (PACK LST))
|
||||
(TERPRI)
|
||||
'T )
|
||||
|
||||
(DEFUN CENTER (MSG)
|
||||
(SET-CURSOR (ROW)
|
||||
(TRUNCATE (- (CADDDR (MAKE-WINDOW)) (LENGTH MSG)) 2))
|
||||
(WRITE-LINE MSG) )
|
||||
|
||||
(METAMIND (RDS))
|
||||
|
||||
59
Microsoft muLISP-86 v51/MOUSE.LSP
Normal file
59
Microsoft muLISP-86 v51/MOUSE.LSP
Normal file
@ -0,0 +1,59 @@
|
||||
; File: MOUSE.LSP 12/29/85 Soft Warehouse, Inc.
|
||||
|
||||
; Microsoft Mouse Interface Functions
|
||||
|
||||
; This file requires that the Microsoft Mouse hardware and device driver
|
||||
; software be properly installed.
|
||||
; The functions automatically update the following global variables:
|
||||
|
||||
; *MOUSE-ROW* the vertical mouse position
|
||||
; *MOUSE-COL* the horizontal mouse position
|
||||
; *LEFT-BUTTON* T if and only if left button pressed
|
||||
; *RIGHT-BUTTON* T if and only if right button pressed
|
||||
; *BUTTON-PRESSES* the number of button presses
|
||||
; *BUTTON-RELEASES* the number of button releases
|
||||
|
||||
(DEFUN SHOW-MOUSE () ;Display mouse cursor
|
||||
(REGISTER 0 1)
|
||||
(INTERRUPT 51) )
|
||||
|
||||
(DEFUN HIDE-MOUSE () ;Hide mouse cursor
|
||||
(REGISTER 0 2)
|
||||
(INTERRUPT 51) )
|
||||
|
||||
(DEFUN POSITION-MOUSE (ROW COL) ;Current mouse position
|
||||
((AND (INTEGERP ROW) (INTEGERP COL))
|
||||
(REGISTER 0 4)
|
||||
(REGISTER 2 COL)
|
||||
(REGISTER 3 ROW)
|
||||
(INTERRUPT 51) )
|
||||
(REGISTER 0 3)
|
||||
(INTERRUPT 51)
|
||||
(SETQ *MOUSE-ROW* (REGISTER 3))
|
||||
(SETQ *MOUSE-COL* (REGISTER 2)) )
|
||||
|
||||
(DEFUN STATUS-MOUSE () ;Current button status
|
||||
(REGISTER 0 3)
|
||||
(INTERRUPT 51)
|
||||
(SETQ *LEFT-BUTTON* (ODDP (REGISTER 1)))
|
||||
(SETQ *RIGHT-BUTTON* (ODDP (SHIFT (REGISTER 1) -1))) )
|
||||
|
||||
(DEFUN BUTTON-PRESS (BUTTON) ;Mouse status at last button press
|
||||
(REGISTER 0 5)
|
||||
(SETQ *BUTTON-PRESSES* (BUTTON-INFO)) )
|
||||
|
||||
(DEFUN BUTTON-RELEASE (BUTTON) ;Mouse status at last button release
|
||||
(REGISTER 0 6)
|
||||
(SETQ *BUTTON-RELEASES* (BUTTON-INFO)) )
|
||||
|
||||
(DEFUN BUTTON-INFO ()
|
||||
(REGISTER 1 (IF (EQ BUTTON 'LEFT) 0 1))
|
||||
(INTERRUPT 51)
|
||||
(SETQ *LEFT-BUTTON* (ODDP (REGISTER 0)))
|
||||
(SETQ *RIGHT-BUTTON* (ODDP (SHIFT (REGISTER 0) -1)))
|
||||
(SETQ *MOUSE-ROW* (REGISTER 3))
|
||||
(SETQ *MOUSE-COL* (REGISTER 2))
|
||||
(REGISTER 1) )
|
||||
|
||||
(RDS)
|
||||
|
||||
BIN
Microsoft muLISP-86 v51/MULISP.COM
Normal file
BIN
Microsoft muLISP-86 v51/MULISP.COM
Normal file
Binary file not shown.
341
Microsoft muLISP-86 v51/MULISP1.LES
Normal file
341
Microsoft muLISP-86 v51/MULISP1.LES
Normal file
@ -0,0 +1,341 @@
|
||||
File: MULISP1.LES (c) 12/27/85 Soft Warehouse, Inc.
|
||||
|
||||
CLRSCRN
|
||||
This is the first of a series of on-line lessons designed to teach the
|
||||
fundamentals of LISP programming using the muLISP dialect of LISP.
|
||||
|
||||
muLISP is a powerful programming language rich in control constructs and
|
||||
functions for operating on user created data structures. However there is a
|
||||
small subset of muLISP, hereafter called pure muLISP, that illustrates many of
|
||||
the fundamental programming concepts required to understand muLISP.
|
||||
|
||||
The first two programming lessons are devoted to teaching pure muLISP. A
|
||||
systematic presentation of the full power of muLISP begins with the third
|
||||
lesson.
|
||||
|
||||
|
||||
CONTINUE
|
||||
muLISP is a symbolic programming language. Most conventional programming
|
||||
languages are primarily designed for numerical processing. Rather than
|
||||
manipulating numerical data structures (like numbers and arrays), muLISP
|
||||
programs typically manipulate symbolic data structures (like words and
|
||||
sentences).
|
||||
|
||||
In muLISP virtually any symbolic data structure can be represented as an
|
||||
object. We will begin these lessons by describing what constitutes an object
|
||||
and how objects can be used to represent symbolic data structures. After
|
||||
that, we will describe how to use muLISP to manipulate these objects.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Data objects can be either simple or composite. Simple data objects are
|
||||
called atoms. In pure muLISP, atoms are indivisible in the sense that they
|
||||
cannot be divided into sub-components. Like people, atoms are referred to by
|
||||
name. Atom names consists of a string of characters. The following are four
|
||||
typical atom names:
|
||||
|
||||
APPLE RABBIT 54321 -41
|
||||
|
||||
Composite data objects are called lists. Lists are made up of zero or more
|
||||
objects, each of which can be simple or composite. Lists are entered and
|
||||
displayed with their elements enclosed in parentheses. The following is a
|
||||
list consisting of four elements:
|
||||
|
||||
(THE QUICK BROWN FOX)
|
||||
|
||||
|
||||
CONTINUE
|
||||
We stated earlier that muLISP is a symbolic programming language because it
|
||||
manipulated symbolic data structures. muLISP is also a functional programming
|
||||
language because functions are used to manipulate the symbolic data
|
||||
structures.
|
||||
|
||||
Given an ordered set of data objects, a muLISP function will return a unique
|
||||
value based upon the data objects it is given. Pure muLISP provides 5
|
||||
primitive functions for manipulating the primitive data objects (i.e. atoms
|
||||
and lists). Writing muLISP "programs" consists of defining additional
|
||||
functions to perform some desired task.
|
||||
|
||||
We will begin the lessons by showing the mechanics of interacting with muLISP.
|
||||
Then we examine the use of each of the 5 primitive functions. Once you have
|
||||
mastered the use of these primitives, you will be ready to begin lesson 2 to
|
||||
learn how to define your own functions in terms of the primitive functions.
|
||||
|
||||
|
||||
CONTINUE
|
||||
In some ways interacting with muLISP is much like using a pocket calculator.
|
||||
First you enter an expression following the dollar sign prompt, then muLISP
|
||||
reads the expression, evaluates it, and displays the result. To prevent the
|
||||
evaluation of an expression, you must precede the expression with a SINGLE
|
||||
QUOTE MARK (also called the apostrophe or accent mark). Do not confuse this
|
||||
with the BACK ACCENT mark found on some keyboards. The following shows what
|
||||
happens when the atom name APPLE is entered:
|
||||
|
||||
$ 'APPLE
|
||||
|
||||
If an atom name is entered without the quote mark, the value of the atom is
|
||||
returned. In pure muLISP atoms evaluate to themselves. Therefore the quote
|
||||
mark before atoms is often not necessary:
|
||||
|
||||
$ APPLE
|
||||
|
||||
To enter atom names of your own, select the Break option by pressing B. When
|
||||
you are ready to return to the lesson, following the dollar sign prompt, type
|
||||
(RETURN) and press the <RETURN> key.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
Lists are entered by enclosing the elements within matching parentheses. The
|
||||
following shows how to enter a list:
|
||||
|
||||
$ '(CAT COW DOG PIG)
|
||||
|
||||
The elements of a list can themselves be lists. For instance, the following
|
||||
list might be part of a data structure describing someone:
|
||||
|
||||
$ '((HEIGHT 72) (WEIGHT 175) (EYES BLUE) (HAIR BLOND))
|
||||
|
||||
If you should forget to precede the list with a single quote mark, you will
|
||||
invoke an "Undefined Function" error. If this should occur, select the
|
||||
Continue option by pressing C and the error will be ignored.
|
||||
|
||||
Press B and try entering some lists of your own. When you are ready to return
|
||||
to the lesson, type (RETURN) and press the <RETURN> key.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
LISP is an acronym for LISt Processing language. Thus as you might expect,
|
||||
muLISP provides primitive functions for operating on lists of objects. One of
|
||||
the most common operations is the extraction or selection of one the members
|
||||
of a list so that it can be examined independently. Functions that perform
|
||||
this service are called selector functions.
|
||||
|
||||
Two of the five primitive pure muLISP functions are selector functions. The
|
||||
CAR function returns the first element of a list. The CDR (pronounced
|
||||
could-er) function returns everything except the first element of a list.
|
||||
|
||||
The nonmnemonic names of these two functions is derived from the original
|
||||
implementation of LISP on an IBM 704 computer in the early 1960's. As we
|
||||
shall see in later lessons, these function names turn out to be convenient
|
||||
despite their now irrelevant origin.
|
||||
|
||||
|
||||
CONTINUE
|
||||
In muLISP, functions calls are made using the format
|
||||
|
||||
(name arg1 arg2 ...)
|
||||
|
||||
where <name> is the function's name, <arg1> is the first argument, <arg2> is
|
||||
the second, etc.
|
||||
|
||||
Note that the left parenthesis precedes the function's name rather than
|
||||
following it as is customary in mathematics and other programming languages.
|
||||
This notational peculiarity alone has probably caused more grief for the
|
||||
novice LISP programmer than any other single thing. However, as you become
|
||||
more familiar with LISP the justification for this unusual notation will
|
||||
become apparent and seem quite natural.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Remember that the function CAR returns the first element of a list. Rather
|
||||
than say "the first element of" a list, most LISP programmers say "the CAR of"
|
||||
a list.
|
||||
|
||||
The following example shows how to find the CAR of the list (DOG CAT COW PIG):
|
||||
|
||||
$ (CAR '(DOG CAT COW PIG))
|
||||
|
||||
During this Break use the function CAR to determine the CAR of the list
|
||||
((RAM 256) (ROM 64) (DISK 322)). Be sure to i) type the function CAR using
|
||||
all capital letters, ii) precede the list with a single quote mark, and iii)
|
||||
balance your parentheses. muLISP ignores extra RIGHT parentheses so you can
|
||||
include a few extra at the right end of an expression.
|
||||
|
||||
When you are ready to return to the lesson, type (RETURN) and press the
|
||||
<RETURN> key.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
The function CDR returns everything but the CAR of a list. The phrase "the
|
||||
CDR of" a list is used instead of the more cumbersome "everything but the
|
||||
first element of" a list.
|
||||
|
||||
The following example shows how to find the CDR of the list (DOG CAT COW PIG):
|
||||
|
||||
$ (CDR '(DOG CAT COW PIG))
|
||||
|
||||
During this break use the function CDR to determine the CDR of the list
|
||||
((HEIGHT 72) (WEIGHT 175) (HAIR BLOND)).
|
||||
|
||||
When you are ready to return to the lesson, type (RETURN) and press the
|
||||
<RETURN> key.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
Up to now the arguments given to functions have been quoted objects. However,
|
||||
there is no reason the value returned by one function call cannot be used as
|
||||
the argument to another function call.
|
||||
|
||||
Consider how to select the second element of a list. The CDR of a list is a
|
||||
list consisting of everything but the first element of the original list.
|
||||
Thus the CAR of the CDR of a list is the second element of the list. The
|
||||
following shows how to find the second element of the list (DOG CAT COW PIG):
|
||||
|
||||
$ (CAR (CDR '(DOG CAT COW PIG)))
|
||||
|
||||
Using combinations of CAR and CDR extract from the list
|
||||
((HEIGHT 72) (WEIGHT 175) (HAIR BLOND)) the sublist (WEIGHT 175) [note that
|
||||
(WEIGHT 175) is the second element of the list]. Then try to extract from the
|
||||
same list just the atom 175 [note that 175 is the second element of the second
|
||||
element of the list].
|
||||
|
||||
BREAK
|
||||
In case you had trouble, here is how to get the 175:
|
||||
|
||||
$ (CAR (CDR (CAR (CDR '((HEIGHT 72) (WEIGHT 175) (HAIR BLOND)) ))))
|
||||
|
||||
|
||||
CONTINUE
|
||||
CAR and CDR are called selector functions because they are used to select or
|
||||
extract the parts of an object. Constructor functions perform the
|
||||
complementary operation of constructing composite objects from simpler
|
||||
objects.
|
||||
|
||||
One of the five primitive pure muLISP functions is the constructor function
|
||||
CONS. CONS is used to add objects to the front of an existing list. Its
|
||||
first argument is the object to be added; its second argument is the existing
|
||||
list. For example:
|
||||
|
||||
$ (CONS 'DOG '(CAT COW PIG))
|
||||
|
||||
Try adding (EYES BROWN) to ((HEIGHT 72) (WEIGHT 175) (HAIR BLOND)). Make sure
|
||||
you balance the parentheses around each argument to CONS.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
Note that the CAR of the result returned by CONS will always be the first
|
||||
argument to CONS. Similarly the CDR of the result will always be the second
|
||||
argument. For example:
|
||||
|
||||
$ (CAR (CONS 'DOG '(CAT COW PIG)))
|
||||
|
||||
$ (CDR (CONS 'DOG '(CAT COW PIG)))
|
||||
|
||||
See if you can CONS the CAR of the list (A B C) onto the CDR of the list
|
||||
(X Y Z) resulting in the list (A Y Z). Again make sure you balance the
|
||||
parentheses around each argument to CONS.
|
||||
|
||||
BREAK
|
||||
The correct answer to the last problem is:
|
||||
|
||||
$ (CONS (CAR '(A B C)) (CDR '(X Y Z)))
|
||||
|
||||
|
||||
CONTINUE
|
||||
In order to make some sense out of muLISP programs it is essential that you
|
||||
learn to "read" function compositions such as the one above. This example
|
||||
should be read as "the CONS of the CAR of the list (A B C) onto the CDR of the
|
||||
list (X Y Z)".
|
||||
|
||||
Use muLISP to find the CONS of the CAR of the CDR of the list
|
||||
(A B C) onto the list (X Y Z). Don't forget to balance those parentheses.
|
||||
|
||||
BREAK
|
||||
The correct answer to the last problem is:
|
||||
|
||||
$ (CONS (CAR (CDR '(A B C))) '(X Y Z))
|
||||
|
||||
|
||||
CONTINUE
|
||||
As mentioned earlier, a muLISP data object is either an atom or a list. Also
|
||||
we explained that the CAR of a list is the first element of the list. What
|
||||
then is the CAR of an atom? Although it is a well-defined operation that does
|
||||
not cause an error, in pure muLISP CAR should not be called with an atomic
|
||||
argument.
|
||||
|
||||
For this and other reasons, we need some way of recognizing whether an object
|
||||
is an atom or a list. The fourth primitive muLISP function we shall discuss
|
||||
is the recognizer function ATOM. ATOM is a function of one argument. If its
|
||||
argument is an atom, ATOM returns the atom T for true; otherwise ATOM returns
|
||||
the atom NIL for false. For example:
|
||||
|
||||
$ (ATOM 'APPLE)
|
||||
|
||||
$ (ATOM '(DOG CAT COW PIG))
|
||||
|
||||
Use the ATOM function to see whether numbers are atoms or not.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
Consider the following ATOM test:
|
||||
|
||||
$ (ATOM '())
|
||||
|
||||
As should be evident by the above example, the empty "list" is not a list at
|
||||
all, but an atom! In fact, muLISP represents the empty list by the atom NIL.
|
||||
Thus:
|
||||
|
||||
$ '()
|
||||
|
||||
Try using muLISP to find the CDR of the single element list '(APPLE).
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
The last primitive pure muLISP function is EQL. It is a comparator function
|
||||
useful for determining if its two atomic arguments are the same atom. For
|
||||
example:
|
||||
|
||||
$ (EQL 'ROM 'RAM)
|
||||
|
||||
$ (EQL (CAR '(DOG CAT COW)) (CAR (CDR '(HORSE DOG PIG))))
|
||||
|
||||
Using the functions CAR, CDR, and EQL, see if the weight specified in the
|
||||
list ((HEIGHT 72) (WEIGHT 175) (HAIR BLOND)) [i.e. the second element of
|
||||
the second element of the list] is 175. Note that there is no need to
|
||||
quote numbers in muLISP, although it is acceptable.
|
||||
|
||||
BREAK
|
||||
Here is how to check the weight equal to 175:
|
||||
|
||||
$ (EQL 175 (CAR (CDR (CAR (CDR '((HEIGHT 72) (WEIGHT 175) (HAIR BLOND)))))))
|
||||
|
||||
|
||||
CONTINUE
|
||||
As stated when EQL was introduced, EQL is useful only for comparing
|
||||
atomic arguments (this statement is not always true in "impure" muLISP). If
|
||||
given lists as arguments (except of course the empty list, which is an atom
|
||||
anyway), EQL will always return NIL. For example:
|
||||
|
||||
$ (EQL '(DOG CAT COW) '(DOG CAT COW))
|
||||
|
||||
One of the projects in the next lesson will be to define a function called
|
||||
EQLIST that is useful for determining the equality of two lists.
|
||||
|
||||
|
||||
CONTINUE
|
||||
In this lesson we have discussed what constitutes muLISP atoms and lists.
|
||||
Collectively these objects are used to make up the symbolic data structure
|
||||
that muLISP functions operate on. Pure muLISP provides the following five
|
||||
primitive functions for operating on objects:
|
||||
|
||||
1. (CAR list) the selector function that returns the first element of
|
||||
<list>;
|
||||
|
||||
2. (CDR list) the selector function that returns everything but the first
|
||||
element of <list>;
|
||||
|
||||
3. (CONS object list) the constructor function that returns the list whose
|
||||
CAR is <object> and whose CDR is <list>;
|
||||
|
||||
4. (EQL atom1 atom2) the comparator function that returns T if <atom1> and
|
||||
<atom2> are the same atom, otherwise it returns NIL;
|
||||
|
||||
5. (ATOM object) the recognizer function that returns T if <object> is an
|
||||
atom, otherwise it returns NIL.
|
||||
|
||||
Congratulations on successfully completing muLISP lesson #1! In lesson #2 you
|
||||
will learn how to write your own muLISP functions.
|
||||
|
||||
CONTINUE
|
||||
$ (RDS)
|
||||
|
||||
518
Microsoft muLISP-86 v51/MULISP2.LES
Normal file
518
Microsoft muLISP-86 v51/MULISP2.LES
Normal file
@ -0,0 +1,518 @@
|
||||
File: MULISP2.LES (c) 12/27/85 Soft Warehouse, Inc.
|
||||
|
||||
CLRSCRN
|
||||
This is the second of a series of on-line lessons designed to teach the
|
||||
fundamentals of LISP programming using the muLISP dialect of LISP.
|
||||
|
||||
The first lesson explained in detail the 5 primitive functions in pure muLISP.
|
||||
In this lesson you will learn how to add your own functions to the basic
|
||||
primitives.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Like primitive functions, user-defined functions are called with arguments and
|
||||
return a single value based upon the arguments. Naturally a function must be
|
||||
defined before it is called with specific arguments. Thus, there must be some
|
||||
means of referring to each of the arguments within the function definition
|
||||
before the actual arguments are known.
|
||||
|
||||
The name used within a function definition to refer to an as yet unspecified
|
||||
ACTUAL ARGUMENT is called a FORMAL ARGUMENT. A list of a function's formal
|
||||
arguments is included at the beginning of its definition.
|
||||
|
||||
The next screen will show how formal arguments are used in a definition.
|
||||
|
||||
|
||||
CONTINUE
|
||||
In pure muLISP, expressions of the following form
|
||||
|
||||
(DEFUN name (arg1 arg2 ...)
|
||||
task1
|
||||
task2
|
||||
... )
|
||||
|
||||
are used to define the function named <name>. The atoms <arg1>, <arg2>, etc.
|
||||
are the formal argument names used for referring to the function's actual
|
||||
arguments. The body of the function is made up of one or more tasks. DEFUN
|
||||
stands for DEfine FUNction.
|
||||
|
||||
We will postpone a full discussion of the component parts of function
|
||||
definitions until a later lesson. For now, we will show how to define
|
||||
functions by example beginning with the next screen.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Some people prefer a more mnemonic name than CAR for the function that returns
|
||||
the first element of a list. This situation can be easily corrected by the
|
||||
following definition:
|
||||
|
||||
$ (DEFUN FIRST (LST)
|
||||
(CAR LST) )
|
||||
|
||||
Note that the function being defined is named FIRST, that the function takes a
|
||||
single argument, that the argument can be referred to by the name LST within
|
||||
the function body, and that the function body consists of a single task which
|
||||
returns the CAR of the argument.
|
||||
|
||||
User-defined functions are called in exactly the same way as the primitive
|
||||
functions. For example:
|
||||
|
||||
$ (FIRST '(DOG CAT COW PIG))
|
||||
|
||||
|
||||
CONTINUE
|
||||
No need to stop with selecting the FIRST element of a list. Here is a
|
||||
definition for selecting the SECOND element of a list:
|
||||
|
||||
$ (DEFUN SECOND (LST)
|
||||
(CAR (CDR LST)) )
|
||||
|
||||
During this break, using the functions CAR and CDR define the function THIRD
|
||||
and try out the functions FIRST, SECOND, and THIRD on some lists. When
|
||||
entering multi-line muLISP expressions, like function definitions, you cannot
|
||||
edit the previous line once the <RETURN> key has been pressed. Thus, make
|
||||
sure each line of a definition is correct before continuing to the next. When
|
||||
you are ready to continue the lesson, type (RETURN) and press the <RETURN>
|
||||
key.
|
||||
|
||||
BREAK
|
||||
Here is our definition for THIRD:
|
||||
|
||||
$ (DEFUN THIRD (LST)
|
||||
(CAR (CDR (CDR LST))) )
|
||||
|
||||
$ (THIRD '(DOG CAT COW PIG))
|
||||
|
||||
CONTINUE
|
||||
In lesson #1 we learned that the atom NIL is used to represent the empty list.
|
||||
NIL was also the atom returned by the functions EQL and ATOM to indicate a
|
||||
false truth value. Since NIL is clearly a very special muLISP atom, it is
|
||||
important to be able to recognize it.
|
||||
|
||||
What we need is a recognizer function called NULL that returns T if its
|
||||
argument is the empty list (i.e. NIL); otherwise it should return NIL. (From
|
||||
now on we will say the "null list" rather than the "empty list".)
|
||||
|
||||
During this Break, define the function NULL (you only need to use one of the
|
||||
5 primitive functions), and then try your new function out on various atoms
|
||||
and lists.
|
||||
|
||||
BREAK
|
||||
Here is our definition for NULL. Note that it is not necessary to quote NIL
|
||||
in the definition, since the value of NIL is NIL. If you used () instead of
|
||||
NIL in the definition, () does not have to be quoted.
|
||||
|
||||
$ (DEFUN NULL (OBJ)
|
||||
(EQL OBJ NIL) )
|
||||
|
||||
$ (NULL '(A B C))
|
||||
|
||||
$ (NULL ())
|
||||
|
||||
CONTINUE
|
||||
Up till now each user-defined function has been essentially just an
|
||||
abbreviation for the single task that makes up the function body. But, the
|
||||
real power of functions comes from their ability to choose between courses of
|
||||
action based upon their arguments.
|
||||
|
||||
Currently we have at our disposal three functions that can be used for
|
||||
testing arguments. They are EQL, ATOM, and NULL. Functions used for testing
|
||||
are often called PREDICATES.
|
||||
|
||||
The next screen describes how to use predicates to make decisions within
|
||||
function definitions.
|
||||
|
||||
|
||||
CONTINUE
|
||||
As you may recall, a function body consists of one or more tasks. In pure
|
||||
muLISP, tasks can be divided into two classes: simple tasks and conditional
|
||||
tasks. A task which is an atom or a list whose CAR (i.e. first element) is an
|
||||
atom is a SIMPLE task. For example:
|
||||
|
||||
(CONS ATM LST)
|
||||
|
||||
The tasks in the functions defined thus far have all been simple tasks. A
|
||||
task which is a list whose CAR is NOT an atom is a CONDITIONAL task. For
|
||||
example:
|
||||
|
||||
((ATOM EXPN) (CONS EXPN LST))
|
||||
|
||||
The CAR of a conditional task is the conditional's predicate. If the
|
||||
predicate returns NIL, the value of task is also NIL and evaluation of the
|
||||
function body proceeds with the next task, if any. If the predicate returns
|
||||
any value other than NIL, the remaining tasks in the function body are ignored
|
||||
and evaluation proceeds using the CDR of the conditional task as the remaining
|
||||
tasks.
|
||||
|
||||
The examples in the next several screens should make this clearer.
|
||||
|
||||
CONTINUE
|
||||
We already have the function ATOM that returns T if and only if its argument
|
||||
is an atom. However, pure muLISP does not have a similar primitive recognizer
|
||||
function for lists. Why not? Because we can write our own if we need it.
|
||||
|
||||
Since our new function will be a LIST Predicate, let's name it LISTP. If its
|
||||
argument is an atom, LISTP should return NIL. If the argument is not an atom,
|
||||
it must be a list and LISTP should return T.
|
||||
|
||||
$ (DEFUN LISTP (OBJ)
|
||||
((ATOM OBJ) NIL)
|
||||
T )
|
||||
|
||||
You can think of the body of this definition as saying: "If OBJ is an atom,
|
||||
return NIL; otherwise return T".
|
||||
|
||||
After trying LISTP out on several objects including the null list, redefine
|
||||
LISTP so it returns T when given the null list.
|
||||
|
||||
BREAK
|
||||
Here is LISTP modified to handle the null list:
|
||||
|
||||
$ (DEFUN LISTP (OBJ)
|
||||
((NULL OBJ))
|
||||
((ATOM OBJ) NIL)
|
||||
T )
|
||||
|
||||
$ (LISTP 'DOG)
|
||||
|
||||
$ (LISTP '())
|
||||
|
||||
$ (LISTP '(DOG CAT COW))
|
||||
|
||||
Note that, since the call on NULL in the first line of LISTP returns T as its
|
||||
value, there is no need to put a T following (NULL OBJ).
|
||||
|
||||
|
||||
CONTINUE
|
||||
If you have created a long list of names, you may want to find out if someone
|
||||
is member of the list. Using the comparator EQL you can compare the name you
|
||||
are looking for with each name on the list. Tentatively, you might start your
|
||||
definition like this:
|
||||
|
||||
(DEFUN MBR (NAM LST)
|
||||
((EQL NAM (FIRST LST)))
|
||||
((EQL NAM (SECOND LST)))
|
||||
((EQL NAM (THIRD LST)))
|
||||
((EQL NAM (THIRD (CDR LST))))
|
||||
...
|
||||
|
||||
Not only is this getting messier by the line, but there is no end to it.
|
||||
After all, you had hoped to use your new function MBR on lists of arbitrary
|
||||
length. So let's consider another approach.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Given a name and a list, consider the following facts:
|
||||
|
||||
1. If the list is null (i.e. has no elements), the name is NOT a member of
|
||||
the list.
|
||||
|
||||
2. If the name is EQL to the CAR of the list, the name is a member of the
|
||||
list.
|
||||
|
||||
3. If the name is not EQL to the CAR of the list, the name is a member of
|
||||
the list if and only if it is a member of the CDR of the list.
|
||||
|
||||
It is absolutely essential that you fully understand and accept the above
|
||||
facts. The first two facts should be fairly straight-forward.
|
||||
|
||||
The third fact is slightly more subtle. It means that if a name is not equal
|
||||
to the first element of a list, then to determine whether or not the name is a
|
||||
member of the list, all you have to do is determine whether or not the name is
|
||||
a member of the CDR of the list.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Let's convert our three facts into a three step procedure for finding out if a
|
||||
name is a member of a list:
|
||||
|
||||
1. If the list is NULL, return NIL.
|
||||
2. If the name is EQL to the CAR of the list, return T.
|
||||
3. Otherwise, use this procedure to find out if the name is a member of the
|
||||
CDR of the list and return the value the procedure returns.
|
||||
|
||||
This is called a recursively defined procedure since step #3 tells us to use
|
||||
the very procedure we are defining to find out if the name is a member of the
|
||||
CDR of the list. The procedure can be easily transformed into a recursive
|
||||
muLISP function definition as follows:
|
||||
|
||||
$ (DEFUN MBR (NAM LST)
|
||||
((NULL LST) NIL)
|
||||
((EQL NAM (CAR LST)) T)
|
||||
(MBR NAM (CDR LST)) )
|
||||
|
||||
Use MBR to see if DOG is a member of (CAT COW DOG PIG).
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
In lesson #1 we mentioned that EQL was only good for comparing atoms, since
|
||||
NIL is returned if lists are compared. For example:
|
||||
|
||||
$ (EQL '(DOG CAT COW) '(DOG CAT COW))
|
||||
|
||||
Using the techniques you learned from MBR, let's define a function called
|
||||
EQLIST that returns T if two lists of atoms are equal; otherwise EQLIST
|
||||
returns NIL. Consider the following recursive procedure for EQLIST and
|
||||
convince yourself of its validity:
|
||||
|
||||
1. If NULL the first list, return NULL the second list.
|
||||
2. If NULL the second list, return NIL.
|
||||
3. If NOT EQL the CAR of the first list to the CAR of the second, return NIL.
|
||||
4. Return EQLIST the CDR of the first list to the CDR of the second.
|
||||
|
||||
During this break define EQLIST and try it out on some examples. If you
|
||||
follow the above procedure, you will also need to define NOT, a predicate
|
||||
function that returns T if its single argument is NIL.
|
||||
|
||||
BREAK
|
||||
Here is our definitions for EQLIST and NOT and an example:
|
||||
|
||||
$ (DEFUN EQLIST (LST1 LST2)
|
||||
((NULL LST1) (NULL LST2))
|
||||
((NULL LST2) NIL)
|
||||
((NOT (EQL (CAR LST1) (CAR LST2))) NIL)
|
||||
(EQLIST (CDR LST1) (CDR LST2)) )
|
||||
|
||||
$ (DEFUN NOT (OBJ)
|
||||
(EQL OBJ NIL) )
|
||||
|
||||
$ (EQLIST '(DOG CAT COW) '(DOG CAT COW))
|
||||
|
||||
Note that the definition of NOT is identical to the definition of NULL that we
|
||||
defined earlier. This is because, as you will recall from lesson #1, muLISP
|
||||
uses the atom NIL to designate both the null list and the truth value false.
|
||||
|
||||
CONTINUE
|
||||
So far the user-defined functions we have written have been either selector
|
||||
functions or predicates. Let's try our hand at a constructor function.
|
||||
Specifically, a function for appending two lists together.
|
||||
|
||||
CONS should immediately spring to mind as the prime candidate for building
|
||||
lists. However, here is what happens if CONS is naively called with two lists
|
||||
as arguments:
|
||||
|
||||
$ (CONS '(DAVE JOAN AL) '(KAREN ANN JOE))
|
||||
|
||||
Instead of being a 6 element list, the result is a 4 element list whose first
|
||||
element is a 3 element list. The result we wanted would have to be CONSed
|
||||
together as follows:
|
||||
|
||||
$ (CONS 'DAVE (CONS 'JOAN (CONS 'AL '(KAREN ANN JOE))))
|
||||
|
||||
Although multiple uses of CONS gives the desired result, what we want is a
|
||||
single function that returns the result when given two arbitrary length lists
|
||||
as arguments.
|
||||
|
||||
CONTINUE
|
||||
Consider the problem of defining the function APPEND in terms of the 5
|
||||
primitive muLISP functions and the user-defined functions that will be defined
|
||||
by the time APPEND is called. Remember APPEND itself qualifies as "a user-
|
||||
defined function that will be defined by the time APPEND is called" (in other
|
||||
words APPEND can be recursively defined).
|
||||
|
||||
Begin by breaking the problem up into cases starting with the simplest case.
|
||||
Given the lists LST1 and LST2,
|
||||
|
||||
1. If LST1 null, return LST2.
|
||||
|
||||
2. Otherwise, CONS the CAR of LST1 onto the list you get by APPENDing the CDR
|
||||
of LST1 onto LST2.
|
||||
|
||||
The next screen defines APPEND and provides more justification for the above
|
||||
procedure. However, if you feel ambitious, try defining APPEND during this
|
||||
break.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
$ (DEFUN APPEND (LST1 LST2)
|
||||
((NULL LST1) LST2)
|
||||
(CONS (CAR LST1) (APPEND (CDR LST1) LST2)) )
|
||||
|
||||
$ (APPEND '(DAVE JOAN AL) '(KAREN ANN JOE))
|
||||
|
||||
To understand this recursive definition, consider individually the two
|
||||
arguments to CONS in the last line of the definition. The first argument,
|
||||
(CAR LST1), is simply the first element of LST1. In the above example, the
|
||||
first argument to CONS is the atom DAVE.
|
||||
|
||||
Assuming our APPEND is working correctly, the second argument to CONS,
|
||||
(APPEND (CDR LST1) LST2), is the list resulting from appending everything but
|
||||
the first element of LST1 to LST2. Note that this is an acceptable use of
|
||||
recursion since each time APPEND calls itself it is with a shorter LST1 so
|
||||
eventually LST1 will be the null list and the recursion will halt. In the
|
||||
above example, the second argument to CONS is the list
|
||||
(JOAN AL KAREN ANN JOE).
|
||||
|
||||
CONTINUE
|
||||
Now its your turn to write some recursively defined constructor functions.
|
||||
Define the function REMBER (REMove memBER) that removes only the first
|
||||
occurrence of an atom from a list. For instance, the call
|
||||
|
||||
(REMBER 'DOG '(CAT DOG COW DOG))
|
||||
|
||||
should return the list (CAT COW DOG). The definition should be of the
|
||||
following form:
|
||||
|
||||
(DEFUN REMBER (OBJ LST)
|
||||
((NULL LST) ...)
|
||||
((... OBJ ...) ...)
|
||||
(CONS ... (REMBER ... ...)) )
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
REMBER can be defined as follows:
|
||||
|
||||
$ (DEFUN REMBER (OBJ LST)
|
||||
((NULL LST) NIL)
|
||||
((EQL OBJ (CAR LST)) (CDR LST))
|
||||
(CONS (CAR LST) (REMBER OBJ (CDR LST))) )
|
||||
|
||||
$ (REMBER 'DOG '(CAR DOG COW DOG))
|
||||
|
||||
If you had trouble with REMBER, you can redeem yourself by defining the
|
||||
function REMBER-ALL. Instead of just the first occurrence,
|
||||
REMBER-ALL removes all occurrences of an atom from a list. Thus
|
||||
|
||||
(REMBER-ALL 'DOG '(CAT DOG COW DOG))
|
||||
|
||||
should return the list (CAT COW). Hint: you need only make a small change to
|
||||
REMBER to get REMBER-ALL.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
REMBER-ALL can be defined as follows:
|
||||
|
||||
$ (DEFUN REMBER-ALL (OBJ LST)
|
||||
((NULL LST) NIL)
|
||||
((EQL OBJ (CAR LST))
|
||||
(REMBER-ALL OBJ (CDR LST)) )
|
||||
(CONS (CAR LST) (REMBER-ALL OBJ (CDR LST))) )
|
||||
|
||||
$ (REMBER-ALL 'DOG '(CAR DOG COW DOG))
|
||||
|
||||
Note the use of indentation in the above definition to highlight the flow of
|
||||
control within the definition. Although we have not stated it explicitly, it
|
||||
should be clear that muLISP is a free format language (i.e. the spacing of the
|
||||
atoms in lists, including function definition lists, is not critical). As you
|
||||
must have discovered by now, what is critical in muLISP is the proper
|
||||
balancing of parentheses!
|
||||
|
||||
|
||||
CONTINUE
|
||||
The last function we shall discuss in Lesson #2 is the constructor function
|
||||
REVERSE. Its effect is simple enough:
|
||||
|
||||
(REVERSE '(DOG CAT COW PIG))
|
||||
|
||||
results in the list (PIG COW CAT DOG). But REVERSE is tricky.
|
||||
|
||||
During this break, see if you can define REVERSE. If you can't figure it out,
|
||||
the next screen gives a hint without giving away the answer.
|
||||
|
||||
BREAK
|
||||
Don't forget that in addition to the 5 primitives, you are free to use all the
|
||||
functions you have already defined including APPEND to write REVERSE.
|
||||
|
||||
The next screen gives a more substantial hint.
|
||||
|
||||
BREAK
|
||||
If you still haven't figured out how to write REVERSE, you may need to work on
|
||||
your RQ (Recursive Quotient)! Using recursion, you can REVERSE the CDR of LST
|
||||
by the call
|
||||
|
||||
(REVERSE (CDR LST))
|
||||
|
||||
Then to REVERSE the whole LST, all that remains is to APPEND the REVERSE of
|
||||
the CDR of LST to the single element list
|
||||
|
||||
(CONS (CAR LST) NIL)
|
||||
|
||||
Give REVERSE one last try during this break.
|
||||
|
||||
BREAK
|
||||
REVERSE can be defined as follows:
|
||||
|
||||
$ (DEFUN REVERSE (LST)
|
||||
((NULL LST) NIL)
|
||||
(APPEND (REVERSE (CDR LST)) (CONS (CAR LST) NIL)) )
|
||||
|
||||
$ (REVERSE '(DOG CAT COW PIG))
|
||||
|
||||
Although this is a logically acceptable definition of REVERSE, it is an
|
||||
extremely inefficient one. This is because APPEND is called for each element
|
||||
of the list to be reversed.
|
||||
|
||||
Let's take a whole new approach in our effort to define REVERSE more
|
||||
efficiently. During this break, think about how you would reverse the order
|
||||
of a stack of sheets of paper.
|
||||
|
||||
CONTINUE
|
||||
The simplest way to reverse a stack of paper is to repeatedly take the top
|
||||
sheet (i.e. the CAR) of the stack and put it on a second stack until the first
|
||||
stack is empty. The second stack should start out empty.
|
||||
|
||||
Given a list and a null list, this is the translation of the above process
|
||||
into a recursive procedure to REVERSE the first list:
|
||||
|
||||
1. If NULL the first list, return the second list.
|
||||
|
||||
2. Otherwise, CONS the CAR of the first list onto the second list and REVERSE
|
||||
the CDR of the first list.
|
||||
|
||||
Based on this procedure, you should now be able to define an efficient REVERSE
|
||||
during this break.
|
||||
|
||||
BREAK
|
||||
REVERSE can be efficiently defined as follows:
|
||||
|
||||
$ (DEFUN REVERSE (LST1 LST2)
|
||||
((NULL LST1) LST2)
|
||||
(REVERSE (CDR LST1) (CONS (CAR LST1) LST2)) )
|
||||
|
||||
$ (REVERSE '(DOG CAT COW PIG))
|
||||
|
||||
Note that although REVERSE is defined with TWO formal arguments, it was called
|
||||
with only ONE actual argument. In general, extra formal arguments are
|
||||
assigned the value NIL, which is often convenient.
|
||||
|
||||
CONTINUE
|
||||
In this lesson you have learned how to extend pure muLISP by defining
|
||||
functions. The following summarizes the major concepts presented in the
|
||||
lesson:
|
||||
|
||||
1. The parts of a definition including the function name, the formal argument
|
||||
list, and the tasks comprising the function body.
|
||||
|
||||
2. Two types of tasks including simple tasks and conditional tasks. Based on
|
||||
the value returned by a predicate function, conditional tasks are used to
|
||||
make decisions when functions are evaluated.
|
||||
|
||||
3. The power and elegance of recursive function definitions. Recursive
|
||||
function definitions are acceptable as long as the arguments in the
|
||||
recursive call are closer to the termination condition.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Congratulations on completing muLISP Lesson #2. Although this concludes our
|
||||
discussion of pure muLISP, it by no means exhausts the potential number of
|
||||
functions that can be written in this subset of muLISP. The following are few
|
||||
functions you might try defining:
|
||||
|
||||
1. (EQUAL list1 list2) an equality comparator of <list1> and <list2>, but
|
||||
unlike EQLIST, it works even if the elements of the lists are not atoms.
|
||||
For example, on the list ((A B (C D)) (E F)).
|
||||
|
||||
2. (SUPER-REVERSE list) reverses all levels of all lists in <list>. For
|
||||
example, ((A B (C D)) (E F)) goes to ((F E) ((D C) B A)).
|
||||
|
||||
3. (UNION set1 set2) returns the set-theoretic union of <set1> and <set2>.
|
||||
(Sets are lists in which no element occurs more than once).
|
||||
|
||||
4. (INTERSECTION set1 set2) returns the intersection of two sets.
|
||||
|
||||
5. (SUBST new old list) replaces all occurrences of <old> with <new> in
|
||||
<list>.
|
||||
|
||||
CONTINUE
|
||||
$ (RDS)
|
||||
|
||||
518
Microsoft muLISP-86 v51/MULISP3.LES
Normal file
518
Microsoft muLISP-86 v51/MULISP3.LES
Normal file
@ -0,0 +1,518 @@
|
||||
File: MULISP3.LES (c) 12/27/85 Soft Warehouse, Inc.
|
||||
|
||||
CLRSCRN
|
||||
This is muLISP lesson #3. Estimated completion time is 50 minutes.
|
||||
|
||||
The first two lessons taught the fundamentals of muLISP programming using
|
||||
pure muLISP. Everything you learned about pure muLISP is of course true
|
||||
of full muLISP; however, there is much that was left unsaid. With this
|
||||
lesson we shall commence describing the full capabilities of muLISP.
|
||||
|
||||
In Lesson #3 we will examine each of the three primitive muLISP data objects
|
||||
in detail. This lesson is primarily informative in nature and does not
|
||||
provide a lot in the way of interesting problems for you to solve. However,
|
||||
it does provide an essential foundation for the later lessons.
|
||||
|
||||
|
||||
CONTINUE
|
||||
There are three types of primitive data objects in muLISP: Symbols, Numbers,
|
||||
and Conses.
|
||||
|
||||
muLISP provides numerous functions for recognizing, comparing, combining, and
|
||||
operating on these primitive data objects. This allows you to construct
|
||||
complex data structures that can accurately model in the computer virtually
|
||||
any real world problem. Therefore, we begin our discussion of muLISP with a
|
||||
description of the three basic data objects.
|
||||
|
||||
As you may recall, pure muLISP has only two types of data objects: Atoms and
|
||||
Lists. In full muLISP, atoms are further subdivided into Symbols and Numbers.
|
||||
In full muLISP, lists are only a subset of the more general structures called
|
||||
binary trees made up of Conses.
|
||||
|
||||
|
||||
CONTINUE
|
||||
The first type of data object we shall discuss is the symbol. Associated with
|
||||
each muLISP symbol are 4 attributes:
|
||||
|
||||
1. Print name string: A unique string of ASCII characters used by the system
|
||||
to identify the symbol on input and to display the symbol on output. A
|
||||
symbol's print name string cannot be changed.
|
||||
|
||||
2. Current value: A symbol's value can be any muLISP data object, including
|
||||
itself. The default value of a symbol is the symbol itself.
|
||||
|
||||
3. Property list: The property list contains the symbol's property values
|
||||
indexed on property keys. See the muLISP lesson on property values for
|
||||
more information about using properties. The default property list of a
|
||||
symbol is the null list.
|
||||
|
||||
4. Function definition: A symbol's function definition is applied to the
|
||||
arguments given when the symbol is called as a function. The default
|
||||
function definition invokes the "Undefined Function" error break.
|
||||
|
||||
|
||||
CONTINUE
|
||||
The recognizer function SYMBOLP returns T if its single argument is a symbol;
|
||||
otherwise it returns NIL. For example:
|
||||
|
||||
$ (SYMBOLP 'XYZ)
|
||||
|
||||
$ (SYMBOLP 41)
|
||||
|
||||
$ (SYMBOLP '(DOG CAT COW))
|
||||
|
||||
During this break, see whether the null list, (), is a symbol or not. To
|
||||
return to the lesson, type (RETURN) and press the <RETURN> key.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
As discussed in an earlier lesson, the comparator function EQL is used to
|
||||
determine if two symbols are the same. For example:
|
||||
|
||||
$ (EQL 'APPLE (CAR '(APPLE ORANGE LEMON)))
|
||||
|
||||
|
||||
CONTINUE
|
||||
Since blank spaces, parentheses, and some other special characters have
|
||||
special significance to the muLISP, a quoted string must be used to create a
|
||||
symbol with such characters in its print name string. Simply enclose the
|
||||
string containing such characters within double quotes to create such a
|
||||
symbol. For example:
|
||||
|
||||
$ "This is a (single) symbol!"
|
||||
|
||||
Normally the double quotes around symbols containing special characters are
|
||||
NOT displayed when the symbol is output. (Note: Double quote marks are
|
||||
automatically displayed around such symbols if the value of the control
|
||||
variable PRIN1 is NIL.)
|
||||
|
||||
The empty string, entered as "", is also a symbol. For example:
|
||||
|
||||
$ (SYMBOLP "")
|
||||
|
||||
CONTINUE
|
||||
The double quote mark itself can be included in a print name string by
|
||||
entering a backslash and a quote mark for each desired quote mark in the
|
||||
string. For example:
|
||||
|
||||
$ "She said, \"I am learning muLISP.\""
|
||||
|
||||
When entering symbols using double quote marks, it is essential to balance the
|
||||
quote marks. After entering a quote mark, muLISP will continue to think you
|
||||
are entering a single symbol until a matching quote mark is read.
|
||||
|
||||
During this break, see what happens when you enter a symbol with an unmatched
|
||||
double quote mark and press the <RETURN> key. To return to the lesson, you
|
||||
will need to balance the quote marks so you will get the dollar sign prompt.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
A symbol can be assigned a value. The value can be any muLISP data object
|
||||
including itself. The default value of most muLISP symbols is the symbol
|
||||
itself.
|
||||
|
||||
SET is the primitive function used to set the value of a symbol (SET's first
|
||||
argument) to a value (SET's second argument). Of secondary importance is the
|
||||
fact that SET returns its second argument as its value. For example:
|
||||
|
||||
$ (SET 'FRUITS '(APPLES ORANGES LEMONS PEARS))
|
||||
|
||||
$ FRUITS
|
||||
|
||||
During this break, SET the symbol VOWELS to a list of the 5 vowels in the
|
||||
alphabet.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
Generally the first argument to SET will be a quoted symbol. Rather than
|
||||
having to explicitly quote the symbol, the function SETQ (SET Quote) can be
|
||||
used instead. SETQ automatically quotes its first argument but NOT its
|
||||
second. For example, rather than using SET to assign a list to 'VOWELS, you
|
||||
could use SETQ as follows:
|
||||
|
||||
$ (SETQ VOWELS '(A E I O U))
|
||||
|
||||
During this break, use SETQ to add the letter Y to VOWELS by CONSing it onto
|
||||
the current value of VOWELS.
|
||||
|
||||
BREAK
|
||||
The following adds Y to the list of vowels:
|
||||
|
||||
$ (SETQ VOWELS (CONS 'Y VOWELS))
|
||||
|
||||
|
||||
CONTINUE
|
||||
The second type of muLISP data object we shall discuss are Numbers. Numbers
|
||||
are further subdivided into integers and ratios. Integers are entered as a
|
||||
contiguous series of digits, optionally preceded by a minus sign.
|
||||
|
||||
Since the value of a number is the number itself, there is no need to quote
|
||||
numbers:
|
||||
|
||||
$ 41
|
||||
|
||||
$ -75
|
||||
|
||||
The comparator function EQL is used to test for the equality of two numbers:
|
||||
|
||||
$ (EQL 3 4)
|
||||
|
||||
$ (EQL 0 -0)
|
||||
|
||||
|
||||
CONTINUE
|
||||
Ratios can be entered using either decimal or slash notation (i.e. as two
|
||||
series of digits separated by a decimal point or a slash character, optionally
|
||||
preceded by a minus sign). By default, ratios are displayed using decimal
|
||||
notation:
|
||||
|
||||
$ 3/4
|
||||
|
||||
$ -0.34
|
||||
|
||||
$ (EQL 0.4 2/5)
|
||||
|
||||
|
||||
CONTINUE
|
||||
If the control variable *POINT* is NIL, muLISP displays ratios using slash
|
||||
notation instead of decimal notation. Note that ratios are automatically
|
||||
reduced to lowest terms. Also ratios having a denominator of one are
|
||||
automatically converted to integers.
|
||||
|
||||
$ (SETQ *POINT* NIL)
|
||||
|
||||
$ -5/7
|
||||
|
||||
$ 0.33333333
|
||||
|
||||
$ 12/9
|
||||
|
||||
$ 5/1
|
||||
|
||||
|
||||
CONTINUE
|
||||
If the control variable *POINT* is zero or a positive integer, muLISP
|
||||
displays ratios using decimal notation to a maximum of POINT digits:
|
||||
|
||||
$ (SETQ *POINT* 3)
|
||||
|
||||
$ 2/3
|
||||
|
||||
$ (SETQ *POINT* 7)
|
||||
|
||||
$ 2/3
|
||||
|
||||
|
||||
CONTINUE
|
||||
The primitive recognizer function INTEGERP returns T if its argument is an
|
||||
integer; otherwise it returns NIL. For example:
|
||||
|
||||
$ (INTEGERP 100)
|
||||
|
||||
$ (INTEGERP 'FIVE)
|
||||
|
||||
$ (SETQ PRIMES '(2 3 5 7 11))
|
||||
|
||||
$ (INTEGERP (CAR PRIMES))
|
||||
|
||||
|
||||
CONTINUE
|
||||
The primitive recognizer function NUMBERP returns T if its argument is a
|
||||
number (i.e. either an integer or ratio); otherwise it returns NIL. For
|
||||
example:
|
||||
|
||||
$ (NUMBERP 100)
|
||||
|
||||
$ (NUMBERP 457.23)
|
||||
|
||||
$ (NUMBERP -23/7)
|
||||
|
||||
|
||||
During this break, use NUMBERP and SYMBOLP to see if a sequence of digits
|
||||
enclosed in double quotes (e.g. "137") is a number or a symbol.
|
||||
|
||||
BREAK
|
||||
The following two tests show that "137" is a symbol rather than a number:
|
||||
|
||||
$ (NUMBERP "137")
|
||||
|
||||
$ (SYMBOLP "137")
|
||||
|
||||
|
||||
CONTINUE
|
||||
Symbols and numbers are collectively called ATOMs to suggest their
|
||||
indivisibility by ordinary means. The primitive recognizer function ATOM
|
||||
returns T if its argument is an atom (i.e. either a symbol or a number);
|
||||
otherwise is returns NIL. For example:
|
||||
|
||||
$ (ATOM 'APPLE)
|
||||
|
||||
$ (ATOM 123)
|
||||
|
||||
$ (ATOM '(DOG CAT COW))
|
||||
|
||||
$ (ATOM '())
|
||||
|
||||
|
||||
CONTINUE
|
||||
Sometimes you may wish to refer to a symbol itself rather than its value. In
|
||||
muLISP, the apostrophe character is used as a quote mark to suppress the
|
||||
evaluation of a symbol. For example:
|
||||
|
||||
$ (SETQ FOO 1492)
|
||||
|
||||
$ FOO
|
||||
|
||||
$ 'FOO
|
||||
|
||||
Note that the apostrophe is different from the "back accent" or "accent grave"
|
||||
character, `, which also occurs on some terminals.
|
||||
|
||||
During this break, use SETQ and the quote mark to set the value of FOO back to
|
||||
itself (i.e. make it be an auto-quoted symbol).
|
||||
|
||||
BREAK
|
||||
The following restores the value of FOO to be itself:
|
||||
|
||||
$ (SETQ FOO 'FOO)
|
||||
|
||||
$ FOO
|
||||
|
||||
|
||||
CONTINUE
|
||||
The third primitive muLISP data object we shall discuss are Conses. A cons
|
||||
is a nonatomic data object that points to two other data objects. The name
|
||||
"cons" comes from the constructor function CONS discussed in the earlier
|
||||
lessons.
|
||||
|
||||
Data can be stored in the computer's memory. The location where a data item
|
||||
is stored is called its ADDRESS. An address is analogous to a street address
|
||||
on a mailbox. The data stored there is analogous to mail in the mailbox. As
|
||||
with mailboxes, the contents of computer memory can change over time.
|
||||
|
||||
Suppose we wish to represent the cons consisting of the symbol BILBO and his
|
||||
age 31. We could store the symbol BILBO beginning at location 7, his age 31
|
||||
at location 2, and beginning at location 4 we could store a cons consisting
|
||||
of the pair of addresses 7 and 2:
|
||||
|
||||
Address: 1 2 3 4 5 6 7
|
||||
+-----+-----+-----+-----+-----+-----+-----+---
|
||||
Contents: | | 31 | | 7 | 2 | |BILBO|
|
||||
+-----+-----+-----+-----+-----+-----+-----+---
|
||||
|
||||
CONTINUE
|
||||
muLISP manages the specific placement of data within memory automatically, so
|
||||
all we care about is the specific primitive symbols and numbers together with
|
||||
the way they are connected. muLISP keeps track of addresses such as 7 and 2
|
||||
in our example, but for us they are a distraction.
|
||||
|
||||
The following "box-car" representation of a cons suppresses such irrelevant
|
||||
detail:
|
||||
|
||||
+-----+-----+
|
||||
| . | . |
|
||||
+-/---+---\-+
|
||||
/ \
|
||||
/ \
|
||||
BILBO 31
|
||||
|
||||
|
||||
CONTINUE
|
||||
If you have seen one box-car, you have seen them all. So, to reduce clutter,
|
||||
I henceforth represent conses by a dot at the vertices in my diagrams. For
|
||||
example:
|
||||
|
||||
.
|
||||
/ \
|
||||
/ \
|
||||
BILBO 31
|
||||
|
||||
Since each cons has exactly two "branches", such diagrams are called binary
|
||||
trees.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Although a linked collection of conses is best envisioned by humans as a
|
||||
binary tree structure, a linearized representation of conses is more suitable
|
||||
for a computer programming language.
|
||||
|
||||
One of the linear representations recognized by muLISP is the so-called DOT
|
||||
notation. In this notation, a cons is represented by a left parenthesis, a
|
||||
data item, a period, a data item, and a right parenthesis. For example, the
|
||||
cons
|
||||
|
||||
.
|
||||
/ \
|
||||
/ \
|
||||
BILBO 31
|
||||
|
||||
is represented in DOT notation as:
|
||||
|
||||
(BILBO . 31)
|
||||
|
||||
CONTINUE
|
||||
The left element of a cons is called the CAR of the cons. The right element
|
||||
is called the CDR of the cons. The elements of a cons can be any data object
|
||||
including another cons. For example, BILBO's last name can be included in our
|
||||
binary tree as:
|
||||
|
||||
.
|
||||
/ \
|
||||
/ \
|
||||
. 31
|
||||
/ \
|
||||
/ \
|
||||
BILBO BAGGINS
|
||||
|
||||
The equivalent dot notation representation of this tree is:
|
||||
|
||||
((BILBO . BAGGINS) . 31)
|
||||
|
||||
|
||||
CONTINUE
|
||||
Let's add the fact that BILBO is a hobbit to our binary tree:
|
||||
|
||||
.
|
||||
/ \
|
||||
/ \
|
||||
. HOBBIT
|
||||
/ \
|
||||
/ \
|
||||
. 31
|
||||
/ \
|
||||
/ \
|
||||
BILBO BAGGINS
|
||||
|
||||
Before continuing think how this three cons binary tree would be represented
|
||||
using dot notation.
|
||||
|
||||
CONTINUE
|
||||
The tree is represented in dot notation as:
|
||||
|
||||
(((BILBO . BAGGINS) . 31) . HOBBIT)
|
||||
|
||||
An alternative binary tree structure for this information is the one
|
||||
corresponding to:
|
||||
|
||||
((BILBO . BAGGINS) . (31 . HOBBIT))
|
||||
|
||||
Sketch the corresponding binary tree diagram on a piece of paper, then hold it
|
||||
close to my face so I can check it out.
|
||||
|
||||
_____
|
||||
/ \
|
||||
>| O.O |<
|
||||
| \=/ |
|
||||
\___/
|
||||
|
||||
CONTINUE
|
||||
Oh well, my eyes must be getting bad. It should have looked something like
|
||||
this:
|
||||
.
|
||||
/ \
|
||||
/ \
|
||||
/ \
|
||||
. .
|
||||
/ \ / \
|
||||
/ \ / \
|
||||
BILBO BAGGINS 31 HOBBIT
|
||||
|
||||
|
||||
From this discussion it should be clear that linked conses can be used to
|
||||
represent virtually any tree structured data.
|
||||
|
||||
|
||||
CONTINUE
|
||||
It is often most natural to represent a collection of conses as a LIST of data
|
||||
objects rather than as a deeply nested binary tree. For example, the elements
|
||||
of a set are usually displayed as a list.
|
||||
|
||||
muLISP represents a list as a linked collection of conses whose CAR cells
|
||||
point to the members of the lists and whose CDR cells point to the next cons.
|
||||
The linked list is terminated by a CDR cell that points to NIL. For example:
|
||||
.
|
||||
/ \
|
||||
/ \
|
||||
object1 .
|
||||
/ \
|
||||
/ \
|
||||
object2 .
|
||||
.
|
||||
.
|
||||
/ \
|
||||
/ \
|
||||
objectN NIL
|
||||
|
||||
CONTINUE
|
||||
When this binary tree is rotated 45 degrees counterclockwise, it is easier to
|
||||
see why it can be used to represent a list of data objects:
|
||||
|
||||
.--------.--- . . . ---.----- NIL
|
||||
| | |
|
||||
| | |
|
||||
object1 object2 objectN
|
||||
|
||||
The linear structure of lists suggests an external printed representation that
|
||||
is much more readable than the equivalent dot notation representation. Thus
|
||||
muLISP will automatically display the above object using LIST notation:
|
||||
|
||||
(object1 object2 ... objectN)
|
||||
|
||||
rather than using dot notation:
|
||||
|
||||
(object1 . (object2 . ... (objectN . NIL) ...))
|
||||
|
||||
CONTINUE
|
||||
The muLISP object display functions use list notation where possible and dot
|
||||
notation where necessary. Thus, a structure of the form
|
||||
.
|
||||
/ \
|
||||
/ \
|
||||
object1 .
|
||||
/ \
|
||||
/ \
|
||||
object2 .
|
||||
.
|
||||
.
|
||||
/ \
|
||||
/ \
|
||||
objectN atom
|
||||
|
||||
where <atom> is not the symbol NIL, is displayed in a mixed notation as:
|
||||
|
||||
(item1 item2 - - - itemN . atom)
|
||||
|
||||
|
||||
CONTINUE
|
||||
The muLISP input reader function accepts list notation, dot notation, and
|
||||
mixed notation. Moreover, any of the elements of a list can themselves be
|
||||
either lists or more general expressions. The following examples show how
|
||||
muLISP displays a few expressions:
|
||||
|
||||
$ '(DOG . (CAT . (COW . PIG)))
|
||||
|
||||
$ '((AGE . 34) . (HOBBIES . (SWIMMING . THINKING)))
|
||||
|
||||
|
||||
CONTINUE
|
||||
During this lesson we have described the three primitive muLISP data objects:
|
||||
Symbols, Numbers, and Conses. The following are the main points to remember:
|
||||
|
||||
1. Symbols: Each symbol has an associated print name string, a value, a
|
||||
property list, and a function definition. Symbols containing special
|
||||
characters can be entered using quoted strings. SETQ is the function
|
||||
most commonly used to assign a value to a symbol.
|
||||
|
||||
2. Numbers: A number is a positive or negative rational number. NUMBERP
|
||||
is used to recognize numbers. Numbers are subdivided into integers or
|
||||
ratios. INTEGERP is used to recognize integers.
|
||||
|
||||
3. Conses: Conses are used to form binary tree structures that can be
|
||||
represented using dot notation, list notation, or mixed notation.
|
||||
|
||||
This concludes muLISP lesson #3.
|
||||
|
||||
|
||||
CONTINUE
|
||||
$ (RDS)
|
||||
|
||||
459
Microsoft muLISP-86 v51/MULISP4.LES
Normal file
459
Microsoft muLISP-86 v51/MULISP4.LES
Normal file
@ -0,0 +1,459 @@
|
||||
File: MULISP4.LES (c) 12/27/85 Soft Warehouse, Inc.
|
||||
|
||||
CLRSCRN
|
||||
This is muLISP programming lesson #4. It requires about 50 minutes to
|
||||
complete. In this lesson we shall discuss the following subjects:
|
||||
|
||||
1. Selector functions, used to select a component part of a binary tree
|
||||
structured data object.
|
||||
|
||||
2. Constructor functions, used to construct binary trees from simpler data
|
||||
objects.
|
||||
|
||||
3. Iterative versus applicative programming in muLISP.
|
||||
|
||||
|
||||
CONTINUE
|
||||
In our discussion of pure muLISP we described the most basic selector
|
||||
functions CAR and CDR in relation to lists. The CAR of a list is the first
|
||||
element of the list. The CDR of a list is everything but the first element
|
||||
of the list. For example:
|
||||
|
||||
$ (CAR '(MARS VENUS MERCURY))
|
||||
|
||||
$ (CDR (CAR (CDR '((VOLUME 90) (DIMENSIONS 3 5 6) (WEIGHT 2000)))))
|
||||
|
||||
Since lists are just a special way of thinking about binary trees, the
|
||||
functions CAR and CDR can also be used on such trees.
|
||||
|
||||
|
||||
CONTINUE
|
||||
As mentioned in the previous lesson, the left branch of a tree is called the
|
||||
CAR branch and the right the CDR branch. Thus as you might expect, the
|
||||
functions CAR and CDR respectively extract the left and right branches of a
|
||||
binary tree. Here are some examples of their use:
|
||||
|
||||
$ (CAR '(GREEN . BLUE))
|
||||
|
||||
$ (CDR '(GREEN . BLUE))
|
||||
|
||||
$ (CAR (CDR '(YELLOW . (RED . BROWN))))
|
||||
|
||||
During this break, extract the renewable energy sources from the binary tree
|
||||
assigned to the variable ENERGY:
|
||||
|
||||
$ (SETQ ENERGY '((OIL . (COAL . SOLAR)) . (WOOD . NUCLEAR)))
|
||||
|
||||
When you are ready to return to the lesson, type (RETURN) and press the
|
||||
<RETURN> key.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
In addition to CAR and CDR, compositions of CAR and CDR are primitively
|
||||
defined in muLISP. These functions are named using the middle letters of CAR
|
||||
and CDR to indicate the particular composition. For example, the function
|
||||
CADR is equivalent to the CAR of the CDR of a list. For example:
|
||||
|
||||
$ (CAR (CDR '(DOG CAT COW)))
|
||||
|
||||
$ (CADR '(DOG CAT COW))
|
||||
|
||||
All other compositions of two, three, and four calls on CAR and CDR are also
|
||||
primitively defined in muLISP. They are named CDAR, CAAR, CDDR, CAAAR, CAADR,
|
||||
CADAR, CDAAR, etc. in the obvious manner. These functions are more efficient
|
||||
than using compositions of CAR and CDR and require less typing.
|
||||
|
||||
During this break, redefine the functions SECOND and THIRD using the
|
||||
composition functions and try them out on some examples.
|
||||
|
||||
BREAK
|
||||
Here is SECOND and THIRD defined using the composition functions:
|
||||
|
||||
$ (DEFUN SECOND (LST)
|
||||
(CADR LST) )
|
||||
|
||||
$ (DEFUN THIRD (LST)
|
||||
(CADDR LST) )
|
||||
|
||||
$ (SECOND '(APPLE ORANGE LEMON PEAR))
|
||||
|
||||
$ (THIRD '(APPLE ORANGE LEMON PEAR))
|
||||
|
||||
|
||||
CONTINUE
|
||||
Thus far we have always accessed a list beginning from the left end.
|
||||
Sometimes it may be necessary to access the last element of a list.
|
||||
|
||||
During this break, recursively define the selector function LAST-ELEMENT that
|
||||
returns the last element of a list and test it out on some lists.
|
||||
|
||||
BREAK
|
||||
This a recursive definition of LAST-ELEMENT. Note that the case where LST
|
||||
is the null list must be handled as a special case:
|
||||
|
||||
$ (DEFUN LAST-ELEMENT (LST)
|
||||
((NULL LST) NIL)
|
||||
((NULL (CDR LST))
|
||||
(CAR LST) )
|
||||
(LAST-ELEMENT (CDR LST)) )
|
||||
|
||||
$ (LAST-ELEMENT '(THE QUICK BROWN FOX))
|
||||
|
||||
|
||||
CONTINUE
|
||||
Up to this point the lessons have taught the APPLICATIVE style of programming.
|
||||
This style emphasizes expression evaluation, functional composition, and
|
||||
recursion.
|
||||
|
||||
muLISP also supports the ITERATIVE style of programming. This style
|
||||
emphasizes iterative control constructs, variable assignments, and sequential
|
||||
processing. The function LOOP is the primary muLISP iterative control
|
||||
construct. LOOP takes any number of arguments, which are sequentially
|
||||
evaluated like the tasks of a function body, except:
|
||||
|
||||
1. After LOOP's last argument is evaluated, control returns back to the first
|
||||
task in the loop.
|
||||
|
||||
2. When a nonNIL conditional task is evaluated in a loop, the value of the
|
||||
conditional is returned as the value of the loop, and evaluation proceeds
|
||||
with the task immediately following the loop, if any.
|
||||
|
||||
There can be any number of conditional exits anywhere within a loop. If there
|
||||
is no such exit, the loop will continue indefinitely.
|
||||
|
||||
CONTINUE
|
||||
To illustrate the use of the LOOP control construct, here is an alternative
|
||||
to the recursive definition of LAST-ELEMENT given earlier:
|
||||
|
||||
$ (DEFUN LAST-ELEMENT (LST)
|
||||
((NULL LST) NIL)
|
||||
(LOOP
|
||||
((NULL (CDR LST))
|
||||
(CAR LST) )
|
||||
(SETQ LST (CDR LST)) ) )
|
||||
|
||||
$ (LAST-ELEMENT '(THE QUICK BROWN FOX))
|
||||
|
||||
During this break, define MBR iteratively using LOOP. (MBR atom list) returns
|
||||
T if <atom> is EQL to any element of <list>; otherwise it returns NIL.
|
||||
|
||||
BREAK
|
||||
An iterative definition of MBR:
|
||||
|
||||
$ (DEFUN MBR (ATM LST)
|
||||
(LOOP
|
||||
((NULL LST) NIL)
|
||||
((EQL ATM (CAR LST)))
|
||||
(SETQ LST (CDR LST)) ) )
|
||||
|
||||
$ (MBR TED '(BOB CAROL TED ALICE))
|
||||
|
||||
|
||||
CONTINUE
|
||||
As you might suspect, muLISP has a primitively defined function, named LAST,
|
||||
for accessing the right end of a list. However, unlike the function
|
||||
LAST-ELEMENT, LAST returns the last cons of a list rather than the last
|
||||
ELEMENT. For example:
|
||||
|
||||
$ (LAST '(TOKYO WASHINGTON LONDON PARIS))
|
||||
|
||||
LAST-ELEMENT can be defined in terms of LAST as follows:
|
||||
|
||||
$ (DEFUN LAST-ELEMENT (LST)
|
||||
(CAR (LAST LST)) )
|
||||
|
||||
$ (LAST-ELEMENT '(TOKYO WASHINGTON LONDON PARIS))
|
||||
|
||||
During this break, guess what the LAST of the following data object is and
|
||||
verify your guess by a call on LAST:
|
||||
|
||||
(23 54 -23 15 . 27)
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
The primitive selector function NTH is useful for extracting the nth element
|
||||
of a list. If <n> is a nonnegative integer, (NTH n list) returns the <n>th
|
||||
element of <list>. muLISP uses ZERO BASED INDEXING to refer to the elements
|
||||
of a list. Therefore, the first element (i.e. the car) of a list is referred
|
||||
to as the 0th element of the list. For example:
|
||||
|
||||
$ (NTH 0 '(BOOK PENCIL PAPER PEN))
|
||||
|
||||
$ (NTH 2 '(BOOK PENCIL PAPER PEN))
|
||||
|
||||
During this break, use NTH to define the function INDEXER such that if <list2>
|
||||
is a list of numbers, then (INDEXER list1 list2) returns a list of the
|
||||
elements of <list1> corresponding to the indices in <list2>. Thus, the call
|
||||
|
||||
(INDEXER '(A B C D E F G) '(6 2 4 0))
|
||||
|
||||
should return the list (G C E A).
|
||||
|
||||
BREAK
|
||||
Here is our definition for INDEXER and an example:
|
||||
|
||||
$ (DEFUN INDEXER (LST1 LST2)
|
||||
((NULL LST2) NIL)
|
||||
(CONS (NTH (CAR LST2) LST1) (INDEXER LST1 (CDR LST2))) )
|
||||
|
||||
$ (INDEXER '(A B C D E F G) '(6 2 4 0))
|
||||
|
||||
|
||||
CONTINUE
|
||||
Whereas NTH returns an element of a list, the primitive selector function
|
||||
NTHCDR returns a tail of a list. If <n> is a nonnegative integer,
|
||||
(NTHCDR n list) returns the <n>th cdr of <list>. For example:
|
||||
|
||||
$ (NTHCDR 0 '(BOOK PENCIL PAPER PEN))
|
||||
|
||||
$ (NTHCDR 2 '(BOOK PENCIL PAPER PEN))
|
||||
|
||||
$ (NTHCDR 5 '(BOOK PENCIL PAPER PEN))
|
||||
|
||||
|
||||
Note that both NTH and NTHCDR return NIL if there are not enough elements
|
||||
in the list.
|
||||
|
||||
CONTINUE
|
||||
Next we shall discuss the primitive muLISP constructor functions.
|
||||
|
||||
In the pure muLISP lessons we described the constructor function CONS in terms
|
||||
of building lists. CONS can also be described in terms of creating binary
|
||||
trees. CONS creates a single cons, the CAR of which is the first argument to
|
||||
CONS and the CDR of which is the second argument. For example:
|
||||
|
||||
$ (CONS 'AGE 43)
|
||||
|
||||
If you want some practice creating binary tree structures, during this break,
|
||||
CONS together the following binary tree:
|
||||
|
||||
(((IBM . PC) . (APPLE . MACINTOSH)) . (TANDY . TRS-80))
|
||||
|
||||
BREAK
|
||||
The computer company tree:
|
||||
|
||||
$ (CONS (CONS (CONS IBM PC) (CONS APPLE MACINTOSH)) (CONS TANDY TRS-80))
|
||||
|
||||
As was explained in the previous lesson, binary trees are displayed using
|
||||
mixed DOT and LIST notation.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Suppose we need to make a list of the values assigned to the variables
|
||||
FIRSTNAME, LASTNAME, and ADDRESS. For example, if the variables were assigned
|
||||
the following values:
|
||||
|
||||
$ (SETQ FIRSTNAME 'Jane)
|
||||
|
||||
$ (SETQ LASTNAME 'Smith)
|
||||
|
||||
$ (SETQ ADDRESS '(Honolulu Hawaii))
|
||||
|
||||
we can construct the desired list by multiple uses of CONS:
|
||||
|
||||
$ (CONS FIRSTNAME (CONS LASTNAME (CONS ADDRESS NIL)))
|
||||
|
||||
|
||||
CONTINUE
|
||||
Rather than having to call CONS for each variable, the primitive function LIST
|
||||
achieves this effect more conveniently. LIST can have any number of
|
||||
arguments. It returns a list of its arguments. For example:
|
||||
|
||||
$ (LIST FIRSTNAME LASTNAME ADDRESS)
|
||||
|
||||
|
||||
CONTINUE
|
||||
Although we defined the function APPEND in an earlier lesson, actually it is a
|
||||
primitively defined muLISP function. APPEND's machine language definition is
|
||||
somewhat more flexible than the user-defined definition, in that the machine
|
||||
language version appends any number of lists together. For example:
|
||||
|
||||
$ (APPEND '(DOG CAT COW) '(SNAKE LIZARD CROCODILE) '(TROUT SALMON TUNA))
|
||||
|
||||
|
||||
CONTINUE
|
||||
The distinction between the three primitive constructor functions we have
|
||||
discussed thus far often leads to some confusion. We can show the effect of
|
||||
the functions CONS, LIST, and APPEND by calling them with the same argument as
|
||||
follows:
|
||||
|
||||
$ (CONS '(DOG CAT) '(COW PIG))
|
||||
|
||||
$ (LIST '(DOG CAT) '(COW PIG))
|
||||
|
||||
$ (APPEND '(DOG CAT) '(COW PIG))
|
||||
|
||||
|
||||
CONTINUE
|
||||
In the pure muLISP lessons, we defined REVERSE efficiently by using an
|
||||
ACCUMULATION variable. The resulting definition was:
|
||||
|
||||
$ (DEFUN REVERSE (LST1 LST2)
|
||||
((NULL LST1) LST2)
|
||||
(REVERSE (CDR LST1) (CONS (CAR LST1) LST2)) )
|
||||
|
||||
$ (REVERSE '(A B C D E))
|
||||
|
||||
During this break, define REVERSE iteratively using the LOOP control
|
||||
construct. You can use the same accumulation variable technique.
|
||||
|
||||
BREAK
|
||||
An iterative definition of REVERSE:
|
||||
|
||||
$ (DEFUN REVERSE (LST1 LST2)
|
||||
(LOOP
|
||||
((NULL LST1) LST2)
|
||||
(SETQ LST2 (CONS (CAR LST1) LST2))
|
||||
(SETQ LST1 (CDR LST1)) ) )
|
||||
|
||||
$ (REVERSE '(A B C D E))
|
||||
|
||||
|
||||
CONTINUE
|
||||
Often while sequentially processing the elements of a list in a loop, we refer
|
||||
to the CAR of the list, then shorten the list by one. This operation is
|
||||
analogous to "popping" the first element off the top of a stack.
|
||||
|
||||
The primitive muLISP function POP facilitates such operations. If <stack> is
|
||||
a symbol whose value is a list, (POP stack) returns the CAR of the list and
|
||||
sets the value of <stack> to the CDR of the list. For example, the last two
|
||||
tasks in the iterative definition of REVERSE,
|
||||
|
||||
(SETQ LST2 (CONS (CAR LST1) LST2))
|
||||
(SETQ LST1 (CDR LST1))
|
||||
|
||||
could be shortened using POP to the single task
|
||||
|
||||
(SETQ LST2 (CONS (POP LST1) LST2))
|
||||
|
||||
|
||||
CONTINUE
|
||||
Another operation commonly used while building a list within a loop is to CONS
|
||||
an object onto the front of a list by an assignment of the form
|
||||
|
||||
(SETQ stack (CONS object stack))
|
||||
|
||||
The primitive function PUSH can shorten such expressions to
|
||||
|
||||
(PUSH object stack)
|
||||
|
||||
During this break, redefine REVERSE iteratively using PUSH and POP.
|
||||
|
||||
BREAK
|
||||
Here is REVERSE defined using PUSH and POP:
|
||||
|
||||
$ (DEFUN REVERSE (LST1 LST2)
|
||||
(LOOP
|
||||
((NULL LST1) LST2)
|
||||
(PUSH (POP LST1) LST2) ) )
|
||||
|
||||
$ (REVERSE '(A B C D E))
|
||||
|
||||
After having written at least four different versions of REVERSE, I hesitate
|
||||
to tell you that REVERSE is actually a primitively defined muLISP function!
|
||||
Naturally, the machine language version is the most efficient.
|
||||
|
||||
|
||||
CONTINUE
|
||||
When a function has completed execution and is ready to return a value, muLISP
|
||||
automatically restores the environment that existed at the time the function
|
||||
was called. This means that you can change the value of the function's formal
|
||||
arguments without being concerned with saving the former values of the formal
|
||||
arguments. For this reason, functions can be regarded as "black boxes" that
|
||||
have no effect on the environment other than their returned value. If it
|
||||
should be necessary for a function to return more than a single value, it can
|
||||
create and return a list of the values.
|
||||
|
||||
Another way a function can affect the outside environment is to make
|
||||
assignments within the function body to variables that are NOT included in its
|
||||
formal argument list. Such variables are called "special", "fluid", or
|
||||
"global" variables. The disadvantage is that it is easy to overlook such
|
||||
hidden communication channels when making program changes, thus making it easy
|
||||
to introduce bugs.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Both the recursive and iterative definitions of REVERSE take time proportional
|
||||
to the length of their argument. But for long lists, the iterative version is
|
||||
perhaps 20 percent faster, depending upon the computer and amount of memory
|
||||
available. However, the recursive version is more compact. When there is
|
||||
such a trade-off between speed and compactness, a good strategy is to program
|
||||
for speed in the most heavily used functions, and program for compactness
|
||||
elsewhere.
|
||||
|
||||
Another consideration when choosing between iteration and recursion is the
|
||||
amount of storage required to perform a given task. Each time a function is
|
||||
called, addresses of the return point and the former values of the formal
|
||||
arguments must be stored on a STACK so that the former environment can be
|
||||
restored when the function returns.
|
||||
|
||||
Since recursion involves repeated nesting of function calls, a recursive
|
||||
function can exhaust all available memory before completing its task. This
|
||||
would invoke the "Memory Space Exhausted" error trap. The use of iteration in
|
||||
such situations might permit the computation to proceed to completion.
|
||||
|
||||
|
||||
CONTINUE
|
||||
muLISP has three primitive logical functions designed to combine truth values
|
||||
returned by predicate functions. The function OR takes any number of
|
||||
arguments and evaluates them from left to right until a nonNIL value is
|
||||
encountered or no arguments are left. If a nonNIL argument is found, OR
|
||||
returns that argument's value; otherwise, OR returns NIL.
|
||||
|
||||
You can rely on the fact that subsequent arguments of OR will not be evaluated
|
||||
after a nonNIL value is encountered. A nonNIL value does not have to be T, so
|
||||
the returned value isn't restricted to T or NIL. For program control
|
||||
purposes, muLISP treats any nonNIL value as T, which is a great programming
|
||||
convenience.
|
||||
|
||||
Remember that a muLISP atom is either a symbol OR a number. Thus, the
|
||||
recognizer function could be defined as:
|
||||
|
||||
$ (DEFUN ATOM (U)
|
||||
(OR (SYMBOLP U) (NUMBERP U)) )
|
||||
|
||||
|
||||
CONTINUE
|
||||
Analogous to OR, there is a built-in AND function that takes any number of
|
||||
arguments. AND evaluates its successive arguments until a NIL value is
|
||||
encountered or no arguments are left. AND returns the value of the last
|
||||
argument that was evaluated. Thus you can rely on the fact that subsequent
|
||||
arguments will not be evaluated after a NIL value is encountered. For
|
||||
example:
|
||||
|
||||
$ (AND (SYMBOLP 'frog) (NUMBERP 7))
|
||||
|
||||
CONTINUE
|
||||
The primitive function NOT returns T if its argument is NIL; otherwise, it
|
||||
returns NIL. For example:
|
||||
|
||||
$ (NOT (ATOM '(SODIUM . CHLORIDE)))
|
||||
|
||||
As we mentioned earlier, the definition of NOT is identical to NULL. NULL
|
||||
should be used when testing for empty lists. NOT should be used when testing
|
||||
the truth value returned by predicate functions.
|
||||
|
||||
|
||||
CONTINUE
|
||||
The following points summarize what we have learned in this lesson:
|
||||
|
||||
1. The use of the 28 primitively defined compositions of CAR and CDR (CADR,
|
||||
CDDR, CAAAR, etc.) for extracting the components of binary trees.
|
||||
|
||||
2. The use of the functions NTH and NTHCDR to index into a list.
|
||||
|
||||
3. The use and distinction between the three primitive constructor functions
|
||||
CONS, LIST, and APPEND.
|
||||
|
||||
4. Iterative programming using the LOOP control construct and the PUSH and
|
||||
POP "stack" functions.
|
||||
|
||||
5. The logical functions AND, OR, and NOT that are used to logically combine
|
||||
the truth values returned by predicate functions.
|
||||
|
||||
This concludes muLISP lesson #4.
|
||||
|
||||
|
||||
CONTINUE
|
||||
$ (RDS)
|
||||
|
||||
391
Microsoft muLISP-86 v51/MULISP5.LES
Normal file
391
Microsoft muLISP-86 v51/MULISP5.LES
Normal file
@ -0,0 +1,391 @@
|
||||
File: MULISP5.LES (c) 12/27/85 Soft Warehouse, Inc.
|
||||
|
||||
CLRSCRN
|
||||
This is muLISP programming lesson #5. This lesson introduces the primitive
|
||||
muLISP numerical functions and presents several techniques useful for writing
|
||||
efficient mathematical functions.
|
||||
|
||||
muLISP provides the user with both infinite precision integer arithmetic and
|
||||
adjustable precision rational arithmetic. This means that the only limit on
|
||||
the size of integers is available computer memory. Integers consisting of
|
||||
thousands of digits are possible. This makes muLISP useful for investigations
|
||||
in the fields of number theory and cryptography.
|
||||
|
||||
By default the precision muLISP uses for rational arithmetic provides about
|
||||
7 digits of accuracy. This approximates the accuracy of single precision
|
||||
floating point arithmetic. The description of the function PRECISION in
|
||||
Chapter 5 of the muLISP Reference Manual provides details on how to increase
|
||||
the precision used for rational arithmetic.
|
||||
|
||||
|
||||
CONTINUE
|
||||
We begin by discussing the primitive numerical functions muLISP provides.
|
||||
The functions +, -, *, and / denote addition, subtraction, multiplication,
|
||||
and division respectively. In most conventional programming languages, you
|
||||
enter numerical expressions using infix notation (i.e. operators appear
|
||||
between their operands). For example:
|
||||
|
||||
3*4 + 5
|
||||
|
||||
Since LISP is a functional programming language, functional notation is more
|
||||
natural and consistent for numerical expressions. For example, the above
|
||||
expression is entered as:
|
||||
|
||||
$ (+ (* 3 4) 5)
|
||||
|
||||
During this break, familiarize yourself with these four numerical functions.
|
||||
When ready to return to the lesson, type (RETURN) and press the <RETURN> key.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
One advantage of functional notation over operator notation is that you are
|
||||
not limited to two operands for each operation. The functions +, *, -,
|
||||
and / can accept a variable number of arguments. For example:
|
||||
|
||||
$ (+ 45 -23 57)
|
||||
|
||||
$ (* 1 2 3 4 5)
|
||||
|
||||
During this break using test cases, empirically determine what the functions
|
||||
- and / do when called with more than two arguments.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
If a numerical function is inadvertently called with nonnumeric arguments, the
|
||||
"Nonnumeric Argument" error message will be displayed on the console followed
|
||||
by the errant function call and the option prompt
|
||||
|
||||
Abort, Break, Continue, Top-level, Restart, System?
|
||||
|
||||
You then must select one of the five options by entering its first letter.
|
||||
The description of the function BREAK in Chapter 5 of the muLISP Reference
|
||||
Manual describes the options in detail. The next screen summarizes the
|
||||
options available.
|
||||
|
||||
CONTINUE
|
||||
Summary of the error break options:
|
||||
|
||||
Abort: aborts execution, returns control directly to the current level
|
||||
of the read-eval-print loop, and prompts the user for further input.
|
||||
|
||||
Break: temporarily suspends execution and prompts the user for input. The
|
||||
errant function can be determined by examining the value of the variable
|
||||
BREAK. To return from the break, type (RETURN expn) where <expn> is the
|
||||
value you want to be returned as the value of the errant function call.
|
||||
|
||||
Continue: continues execution with the errant function call used as the value
|
||||
returned.
|
||||
|
||||
Top-level: aborts execution, returns control to the top-level read-eval-
|
||||
print loop, and prompts the user for further input.
|
||||
|
||||
Restart: abandons the current muLISP environment and starts up a fresh muLISP
|
||||
system.
|
||||
|
||||
System: terminates muLISP and returns to the host operating system.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Enough of errors, let's return to mathematics! The factorial of a number is
|
||||
of great importance in probability theory. The factorial of a nonnegative
|
||||
integer N, denoted N!, can be recursively defined as follows:
|
||||
|
||||
0! = 1,
|
||||
N! = N*(N-1)! if N > 0
|
||||
|
||||
The equivalent muLISP definition of FACTORIAL is:
|
||||
|
||||
$ (DEFUN FACTORIAL (N)
|
||||
((EQL N 0) 1)
|
||||
(* N (FACTORIAL (- N 1))) )
|
||||
|
||||
$ (FACTORIAL 5)
|
||||
|
||||
This is an efficient definition; however, if N is large there is the
|
||||
possibility of a memory space exhausted error because of a stack-overflow.
|
||||
During this break, write and test an iterative version of FACTORIAL. Hint:
|
||||
you will need an accumulation variable for the result.
|
||||
|
||||
BREAK
|
||||
An iterative definition for FACTORIAL and an example:
|
||||
|
||||
$ (DEFUN FACTORIAL (N
|
||||
% Local: % RSLT)
|
||||
(SETQ RSLT 1)
|
||||
(LOOP
|
||||
((ZEROP N) RSLT)
|
||||
(SETQ RSLT (* N RSLT))
|
||||
(SETQ N (- N 1)) ) )
|
||||
|
||||
$ (FACTORIAL 100)
|
||||
|
||||
As the example illustrates, muLISP can handle very large numbers. In the
|
||||
definition we introduced the primitive recognizer function ZEROP. (ZEROP N)
|
||||
is equivalent to (EQL N 0) but is slightly more efficient.
|
||||
|
||||
CONTINUE
|
||||
A series that keeps turning up in nature in the strangest places is the
|
||||
Fibonacci Series. The Nth Fibonacci number, denoted F(N), can be recursively
|
||||
defined as follows:
|
||||
|
||||
F(0) = 1,
|
||||
F(1) = 1,
|
||||
F(N) = F(N-1) + F(N-2) if N > 1.
|
||||
|
||||
The equivalent muLISP definition of FIBONACCI is:
|
||||
|
||||
$ (DEFUN FIBONACCI (N)
|
||||
((ZEROP N) 1)
|
||||
((EQL N 1) 1)
|
||||
(+ (FIBONACCI (- N 1)) (FIBONACCI (- N 2))) )
|
||||
|
||||
$ (FIBONACCI 10)
|
||||
|
||||
During this break, gain a feel for the efficiency of the above algorithm by
|
||||
calling FIBONACCI with progressively larger arguments.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
As you test cases should have demonstrated, this is an extremely inefficient
|
||||
algorithm. The problem is that to compute the Nth Fibonacci number, the
|
||||
(N-2)th Fibonacci number is unnecessarily computed twice, the (N-3)th three
|
||||
times, the (N-4)th five times, and it keeps gets getting worse.
|
||||
|
||||
Since this is a recursive algorithm, most people jump to the conclusion that
|
||||
recursion is the problem, and set about writing a messy iterative definition
|
||||
to achieve efficiency. But the problem is not recursion but the algorithm.
|
||||
|
||||
Rather than computing the Nth Fibonacci number by working backward toward
|
||||
zero, the efficient way is to start at zero and work up to the Nth Fibonacci
|
||||
number using two variables to store the two most recently computed Fibonacci
|
||||
numbers.
|
||||
|
||||
During this break, use this approach to define an efficient, yet recursive,
|
||||
definition for Fibonacci numbers calling it FIB. Compare the efficiency of
|
||||
FIB with FIBONACCI.
|
||||
|
||||
BREAK
|
||||
An efficient, recursive definition for Fibonacci numbers:
|
||||
|
||||
$ (DEFUN FIB (N F1 F2)
|
||||
((ZEROP N) F1)
|
||||
(FIB (- N 1) (+ F1 F2) F1) )
|
||||
|
||||
$ (FIB 10 1 0)
|
||||
|
||||
$ (FIBONACCI 10)
|
||||
|
||||
FIB is a function of 3 arguments. The first argument is N, the second must be
|
||||
1, and the third 0. If you insist on a single argument Fibonacci function,
|
||||
you can define a "front-end" function that merely calls FIB with the
|
||||
appropriate second and third arguments.
|
||||
|
||||
For those of you still not convinced of the elegance and efficiency of
|
||||
recursion, write an iterative definition for Fibonacci numbers and compare it
|
||||
to the above definition. If you are a believer, you can simply continue on.
|
||||
|
||||
CONTINUE
|
||||
Raising an expression to an integer power is certainly an important
|
||||
mathematical operation. To raise N to Mth power all you have to do is
|
||||
multiply N times itself M times.
|
||||
|
||||
During this break, write an iterative definition of POWER as a function of two
|
||||
arguments.
|
||||
|
||||
BREAK
|
||||
A iterative definition of POWER:
|
||||
|
||||
$ (DEFUN POWER (N M
|
||||
% Local: % RSLT )
|
||||
(SETQ RSLT 1)
|
||||
(LOOP
|
||||
((ZEROP M) RSLT)
|
||||
(SETQ RSLT (* N RSLT))
|
||||
(SETQ M (SUB1 M)) ) )
|
||||
|
||||
$ (POWER 2 10)
|
||||
|
||||
The call to the primitive function SUB1 in the above definition is equivalent
|
||||
to, but slightly more efficient, than the call (- N 1) would be. ADD1 is also
|
||||
a primitively defined muLISP function.
|
||||
|
||||
There is an even more efficient way of computing powers of numbers than this
|
||||
iterative technique. On to the next screen!
|
||||
|
||||
|
||||
CONTINUE
|
||||
Consider the following facts:
|
||||
|
||||
1. If M is an even number, then N to Mth power is equal to N squared raised
|
||||
to the M/2th power.
|
||||
|
||||
2. If M is odd, then N to Mth power is N times N raised to the (M-1)th power.
|
||||
|
||||
To implement this algorithm you will need the primitive recognizer function
|
||||
EVENP. It returns T if and only if its argument is an even integer; otherwise
|
||||
it returns NIL.
|
||||
|
||||
During this break, define POWER using the recursive squaring approach
|
||||
described above.
|
||||
|
||||
BREAK
|
||||
An efficient, recursive definition of POWER:
|
||||
|
||||
$ (DEFUN POWER (N M)
|
||||
((ZEROP M) 1)
|
||||
((EVENP M)
|
||||
(POWER (* N N) (/ M 2)) )
|
||||
(* N (POWER N (SUB1 M))) )
|
||||
|
||||
$ (POWER 10 100)
|
||||
|
||||
CONTINUE
|
||||
The primitive function TRUNCATE is useful for converting ratios and quotients
|
||||
to integers. If <n> is a number, (TRUNCATE n) truncates <n> to the nearest
|
||||
integer in the direction of zero:
|
||||
|
||||
$ (TRUNCATE 7/3)
|
||||
|
||||
$ (TRUNCATE -0.95)
|
||||
|
||||
|
||||
If called with two arguments, TRUNCATE returns their truncated integer
|
||||
quotient. Note that (TRUNCATE n m) is equivalent to (TRUNCATE (/ n m)):
|
||||
|
||||
$ (TRUNCATE 7 3)
|
||||
|
||||
$ (TRUNCATE -46.3 5.2)
|
||||
|
||||
|
||||
CONTINUE
|
||||
TRUNCATE returns the truncated integer quotient of its two arguments. The
|
||||
primitive function REM returns the corresponding remainder of its two
|
||||
arguments. TRUNCATE and REM are defined so they observe the law between
|
||||
quotients and remainders: If (TRUNCATE n m) returns the integer q and
|
||||
(REM n m) returns the number r, then
|
||||
|
||||
n = q*m + r
|
||||
|
||||
Often it is useful to obtain both the quotient and remainder at the cost
|
||||
of only one division. The primitive function DIVIDE returns cons of the
|
||||
quotient and remainder of its two arguments.
|
||||
|
||||
$ (TRUNCATE 7 3)
|
||||
|
||||
$ (REM 7 3)
|
||||
|
||||
$ (DIVIDE 7 3)
|
||||
|
||||
|
||||
CONTINUE
|
||||
The Greatest Common Divisor (GCD) of two integers is the largest nonnegative
|
||||
integer number that evenly divides both integers. Euclid's algorithm for the
|
||||
GCD of the integers N and M can be paraphrased as:
|
||||
|
||||
1. If N = 0, then GCD (N, M) = M;
|
||||
|
||||
2. Otherwise, GCD (N, M) = GCD (M mod N, N).
|
||||
|
||||
During this break, define the function GCD using Euclid's algorithm and try it
|
||||
out on some examples. Use the function REM to obtain M mod N.
|
||||
|
||||
BREAK
|
||||
Recursive definition of GCD using Euclid's algorithm:
|
||||
|
||||
$ (DEFUN GCD (N M)
|
||||
((ZEROP N) M)
|
||||
(GCD (REM M N) N) )
|
||||
|
||||
$ (GCD 21 56)
|
||||
|
||||
Actually the functions GCD and LCM (Least Common Multiple) are primitively
|
||||
defined in muLISP. Naturally the primitive versions are faster and can accept
|
||||
an arbitrary number of arguments.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Finally we need to mention the primitive numerical comparator functions: =,
|
||||
/=, <, >, <=, and >=. For example:
|
||||
|
||||
$ (= 34 34.0) ;Equal test
|
||||
|
||||
$ (/= 3/4 0.75) ;Not equal test
|
||||
|
||||
$ (< 67 45) ;Less than test
|
||||
|
||||
$ (>= 19 17 17) ;Greater than or equal test
|
||||
|
||||
As the last example shows, the numerical comparator functions can be called
|
||||
with more than two arguments. If called with nonnumeric arguments, these
|
||||
functions will cause a "Nonnumeric Argument" error break.
|
||||
|
||||
|
||||
CONTINUE
|
||||
To determine if a number lies within a given interval, the function < can be
|
||||
called with 3 arguments. For example, to determine if "g" is a lower case
|
||||
letter enter:
|
||||
|
||||
$ (< 96 (ASCII 'g) 123)
|
||||
|
||||
The function ASCII returns the ASCII code if given a character name. It
|
||||
returns the equivalent ASCII character if given a number between 0 and 256.
|
||||
|
||||
During this break, write the recognizer function LOWERCASE that determines if
|
||||
a character is a lower case character.
|
||||
|
||||
BREAK
|
||||
The LOWERCASE recognizer function:
|
||||
|
||||
$ (DEFUN LOWERCASE (CHAR)
|
||||
(< 96 (ASCII CHAR) 123) )
|
||||
|
||||
$ (LOWERCASE 'g)
|
||||
|
||||
CONTINUE
|
||||
Let's finish off this lesson by writing a function for sorting a list of
|
||||
numbers into increasing order. We are not too concerned with efficiency so
|
||||
let's use a simple "insertion sort" algorithm that is adequate for short
|
||||
lists.
|
||||
|
||||
First we need a function that inserts an number in the proper place in a
|
||||
sorted list of numbers. During this break, write INSERT-NUM, a function that
|
||||
inserts NUM into LST. Use iteration or recursion depending on your taste.
|
||||
|
||||
BREAK
|
||||
A recursively defined INSERT-NUM function:
|
||||
|
||||
$ (DEFUN INSERT-NUM (NUM LST)
|
||||
((NULL LST)
|
||||
(LIST NUM) )
|
||||
((< NUM (CAR LST))
|
||||
(CONS NUM LST) )
|
||||
(CONS (CAR LST) (INSERT-NUM NUM (CDR LST))) )
|
||||
|
||||
$ (INSERT-NUM 12 '(5 9 11 14 19 21))
|
||||
|
||||
During this break, use INSERT-NUM to write the function NUMBER-SORT that sorts
|
||||
a list of numbers.
|
||||
|
||||
BREAK
|
||||
A recursive defined NUMBER-SORT function:
|
||||
|
||||
$ (DEFUN NUMBER-SORT (LST)
|
||||
((NULL LST) NIL)
|
||||
(INSERT-NUM (CAR LST) (NUMBER-SORT (CDR LST))) )
|
||||
|
||||
$ (NUMBER-SORT '(34 23 -14 27 56 22 83))
|
||||
|
||||
|
||||
The built-in function SORT uses an efficient list merge sort. If <test> is
|
||||
a comparator function, (SORT list test) sorts and returns <list> based on
|
||||
<test>. For example:
|
||||
|
||||
$ (SORT '(34 23 -14 27 56 22 83) '<)
|
||||
|
||||
|
||||
This concludes our discussion of numerical programming techniques using
|
||||
muLISP. Congratulations on successfully completing lesson #5.
|
||||
|
||||
CONTINUE
|
||||
$ (RDS)
|
||||
|
||||
620
Microsoft muLISP-86 v51/MULISP6.LES
Normal file
620
Microsoft muLISP-86 v51/MULISP6.LES
Normal file
@ -0,0 +1,620 @@
|
||||
File: MULISP6.LES (c) 12/27/85 Soft Warehouse, Inc.
|
||||
|
||||
CLRSCRN
|
||||
This is muLISP programming lesson #6. In this lesson we will provide muLISP
|
||||
with both line-drawing and "turtle" graphics capabilities.
|
||||
|
||||
First we will define a function for plotting points on the computer screen.
|
||||
Next we will write a routine for drawing straight lines across the screen.
|
||||
Finally, we will use a polynomial approximation to define functions for
|
||||
finding the sine and cosine of an angle. Once these steps have been
|
||||
accomplished, it is relatively easy to implement turtle graphics.
|
||||
|
||||
The LOGO computer language has popularized the idea of using turtle graphics
|
||||
to teach children to program. LOGO was first implemented in LISP and it
|
||||
remains a close cousin. Turtle graphics is based on the idea of a "turtle"
|
||||
that has a heading and a position on the graphics screen. Figures are drawn
|
||||
by issuing commands to the turtle, which draws a line as it moves around the
|
||||
screen.
|
||||
|
||||
|
||||
CONTINUE
|
||||
muLISP is available for a variety of computers and terminals, many of which do
|
||||
not support high resolution graphics. The systems that do support graphics
|
||||
have widely varying graphics protocols. Consequently, to make this lesson
|
||||
applicable to the greatest possible number of systems, the lesson begins by
|
||||
implementing "character graphics" using only ASCII characters positioned using
|
||||
the cursor addressing function (SET-CURSOR row column).
|
||||
|
||||
If you are running on a computer type that supports cursor positioning, the
|
||||
definition for the function SET-CURSOR is built-in. Otherwise, you must
|
||||
either define your own SET-CURSOR function. If SET-CURSOR is working
|
||||
correctly, the command
|
||||
|
||||
(SET-CURSOR 0 0)
|
||||
|
||||
will position the cursor at the upper left corner of the screen. During this
|
||||
break, make sure that SET-CURSOR is working correctly.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
We will assign the global variable ROWS to be the number of rows of characters
|
||||
on the computer screen. COLUMNS is the number of columns. Thus the command
|
||||
|
||||
(SET-CURSOR (SUB1 ROWS) (SUB1 COLUMNS))
|
||||
|
||||
should position the cursor at the lower right corner of the screen. If the
|
||||
following assignments are inappropriate for your computer screen, correct them
|
||||
during this break:
|
||||
|
||||
$ (SETQ COLUMNS 80)
|
||||
|
||||
$ (SETQ ROWS 24)
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
Rather than using rows and columns, the position of a point on a graphics
|
||||
screen is specified by giving it X and Y coordinates relative to an origin.
|
||||
The X-coordinate of a point is the horizontal distance from the origin to the
|
||||
point; it is positive if the point is to the right of the origin, negative if
|
||||
to the left. The Y-coordinate of a point is the vertical distance from the
|
||||
origin to the point; it is positive if the point is above the origin, negative
|
||||
if below.
|
||||
|
||||
Y
|
||||
|
|
||||
|
|
||||
------+------ X
|
||||
|
|
||||
|
|
||||
|
||||
Coordinates are normally written as a pair of numbers between square brackets;
|
||||
the first is the X-coordinate, the second is the Y-coordinate. For example
|
||||
the origin of the coordinate system is the point at [0 0]. Generally, the
|
||||
center of the screen is chosen as the origin for graphics routines.
|
||||
|
||||
|
||||
CONTINUE
|
||||
SET-CURSOR uses the upper left corner of the screen as its origin and it
|
||||
is called with coordinates in the opposite order to that used in a graphics
|
||||
coordinate system. Thus we define the function DOT that plots a character
|
||||
at a specified coordinate on the screen:
|
||||
|
||||
$ (DEFUN DOT (X-COORD Y-COORD
|
||||
LINELENGTH )
|
||||
((AND (< (- X-MAX) X-COORD X-MAX)
|
||||
(< (- Y-MAX) Y-COORD Y-MAX) )
|
||||
(SET-CURSOR (- Y-MAX Y-COORD) (+ X-MAX X-COORD))
|
||||
(PRIN1 DOT) ) )
|
||||
|
||||
$ (SETQ X-MAX (TRUNCATE (ADD1 COLUMNS) 2))
|
||||
|
||||
$ (SETQ Y-MAX (TRUNCATE (ADD1 ROWS) 2))
|
||||
|
||||
LINELENGTH is included in DOT's formal argument list to temporarily set this
|
||||
control variable to NIL, thus defeating muLISP's automatic line termination
|
||||
feature while plotting points.
|
||||
|
||||
CONTINUE
|
||||
The character that is displayed when plotting a point is determined by the
|
||||
value of the control variable DOT.
|
||||
|
||||
$ (SETQ DOT '*)
|
||||
|
||||
Computers that have extended the ASCII character set may have a more
|
||||
appropriate character to use for plotting points. For example, (ASCII 2) is
|
||||
a "smiley" circle on the IBM PC. During this break you can reassign DOT, if
|
||||
you so desire.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
The function DRAW is a convenient means of clearing the screen,
|
||||
performing several graphics operations, and then returning the cursor
|
||||
to the top left corner of the screen:
|
||||
|
||||
$ (DEFUN DRAW (NLAMBDA COMMANDS
|
||||
(CLEAR-SCREEN)
|
||||
(MAPC 'EVAL COMMANDS)
|
||||
(SET-CURSOR 0 0) ))
|
||||
|
||||
During this break, test out DOT by issuing the command
|
||||
|
||||
(DRAW (DOT 15 8) (DOT 15 -8) (DOT -15 -8) (DOT -15 8))
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
Now that we can plot points, the next step is to implement a line-drawing
|
||||
routine. But first we must introduce a couple of primitively defined,
|
||||
numerical functions that are required by the line-drawing algorithm.
|
||||
|
||||
The function ABS returns the absolute value of its argument:
|
||||
|
||||
$ (ABS 24.3)
|
||||
|
||||
$ (ABS -16)
|
||||
|
||||
$ (ABS 0)
|
||||
|
||||
|
||||
CONTINUE
|
||||
The function SIGNUM returns 1 if its argument is positive, -1 if its argument
|
||||
is negative, and 0 if its argument is zero:
|
||||
|
||||
$ (SIGNUM -7)
|
||||
|
||||
$ (SIGNUM 5.3)
|
||||
|
||||
$ (SIGNUM 0.0)
|
||||
|
||||
|
||||
CONTINUE
|
||||
Bresenham's algorithm is a particularly fast line-drawing algorithm because it
|
||||
involves only addition and subtraction. It is described in books on graphics
|
||||
such as "Principles of Computer Graphics" by William M. Newman and Robert F.
|
||||
Sproull (McGraw-Hill Book Company, 1979). We will use it to define the
|
||||
function LINE that draws a line from [x1 y1] to [x2 y2].
|
||||
|
||||
|
||||
CONTINUE
|
||||
If a line segment has a gradual slope (i.e. less than 45 degrees), the line-
|
||||
drawing routine must plot several adjacent points with the same Y-coordinate.
|
||||
Thus, for lines with a gentle slope, Bresenham's algorithm plots points as a
|
||||
function of the X-coordinate. On the other hand, if a line is steep, adjacent
|
||||
points are plotted as a function of the Y-coordinate. LINE calls STEEP-SLOPE
|
||||
or GENTLE-SLOPE depending on the steepness of the line being drawn:
|
||||
|
||||
$ (DEFUN LINE (X1 Y1 X2 Y2
|
||||
DELTA-X DELTA-Y SIGN-DELTA-X SIGN-DELTA-Y)
|
||||
(SETQ DELTA-X (- X2 X1)
|
||||
DELTA-Y (- Y2 Y1)
|
||||
SIGN-DELTA-X (SIGNUM DELTA-X)
|
||||
SIGN-DELTA-Y (SIGNUM DELTA-Y)
|
||||
DELTA-X (ABS DELTA-X)
|
||||
DELTA-Y (ABS DELTA-Y))
|
||||
((< DELTA-Y DELTA-X)
|
||||
(GENTLE-SLOPE) )
|
||||
(STEEP-SLOPE) )
|
||||
|
||||
|
||||
CONTINUE
|
||||
The gradual slope line-drawing function:
|
||||
|
||||
$ (DEFUN GENTLE-SLOPE ()
|
||||
(SETQ DELTA-Y (* 2 DELTA-Y)
|
||||
Y2 (- DELTA-Y DELTA-X)
|
||||
DELTA-X (- DELTA-X Y2))
|
||||
(LOOP
|
||||
(DOT X1 Y1)
|
||||
((EQ X1 X2))
|
||||
( ((PLUSP Y2)
|
||||
(INCQ Y1 SIGN-DELTA-Y)
|
||||
(DECQ Y2 DELTA-X) )
|
||||
(INCQ Y2 DELTA-Y) )
|
||||
(INCQ X1 SIGN-DELTA-X) ) )
|
||||
|
||||
Note the use of the special forms INCQ (INCrement Quote) and DECQ (DECrement
|
||||
Quote) in the definition of GENTLE-SLOPE. If <variable> is a symbol and <n>
|
||||
is a number, (INCQ variable n) adds <n> to the value of <variable>. It is
|
||||
equivalent to (SETQ variable (+ variable n)), but is more efficient. If INCQ
|
||||
is called without a second argument, <variable> is incremented by one. DECQ
|
||||
is analogous to INCQ except it subtracts from its first argument.
|
||||
|
||||
CONTINUE
|
||||
The steep slope line-drawing function:
|
||||
|
||||
$ (DEFUN STEEP-SLOPE ()
|
||||
(SETQ DELTA-X (* 2 DELTA-X)
|
||||
X2 (- DELTA-X DELTA-Y)
|
||||
DELTA-Y (- DELTA-Y X2))
|
||||
(LOOP
|
||||
(DOT X1 Y1)
|
||||
((EQ Y1 Y2))
|
||||
( ((PLUSP X2)
|
||||
(INCQ X1 SIGN-DELTA-X)
|
||||
(DECQ X2 DELTA-Y) )
|
||||
(INCQ X2 DELTA-X) )
|
||||
(INCQ Y1 SIGN-DELTA-Y) ) )
|
||||
|
||||
The line-drawing function LINE is now complete. For example, the command
|
||||
|
||||
(DRAW (LINE -20 -5 0 10) (LINE 0 10 20 -5) (LINE 20 -5 -20 -5))
|
||||
|
||||
should draw a triangle on the screen. During this break, try drawing a box
|
||||
using LINE.
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
Rather than using an absolute coordinate system to draw figures, turtle
|
||||
graphics uses polar coordinates (i.e. line segments are specified by giving a
|
||||
distance and an angle from a starting point). To use our LINE function we
|
||||
must convert from polar to absolute coordinates. Thus we need to define
|
||||
functions for finding the sine and cosine of an angle.
|
||||
|
||||
No matter how accurately the sine (or cosine) is computed, when multiplied by
|
||||
the length of a line segment and the result rounded to the nearest integer,
|
||||
the resulting coordinate can differ by one from what it would be if an exact
|
||||
sine (or cosine) were used. Using least-squares polynomials, we can compute
|
||||
sufficiently accurate rational approximations for the sine and cosine of an
|
||||
angle to insure that the error never exceeds one "pixel" (i.e. a graphics
|
||||
point). In fact, an error of one pixel is relatively unlikely for even the
|
||||
longest line segment that will fit on our screen.
|
||||
|
||||
It is always possible to reduce sines and cosines to equivalent ones in the
|
||||
range 0 through 45 degrees. Hence we begin by defining sine and cosine
|
||||
functions restricted to that range.
|
||||
|
||||
CONTINUE
|
||||
Throughout the 0 through 45 degree range, a least-squares fitted quintic
|
||||
polynomial differs from sine by less than 1 part per 3000, while a least-
|
||||
squares fitted quartic polynomial differs from cosine by less than 1 part per
|
||||
2000. The diagonal of an 80 by 24 screen is less than 84 units, so if the
|
||||
maximum truncation error occurred at this particular bearing and if we move a
|
||||
distance equal to the entire diagonal, there would be about 84 chances out of
|
||||
2000 for an error of one pixel.
|
||||
|
||||
$ (DEFUN REDUCED-SIN (DEG)
|
||||
(/ (* DEG (+ 1324959969 (* (SETQ DEG (* DEG DEG)) (+ -67245 DEG))))
|
||||
75914915920) )
|
||||
|
||||
$ (DEFUN REDUCED-COS (DEG)
|
||||
(SETQ DEG (* DEG DEG))
|
||||
(/ (+ 266153374 (* DEG (+ -40518 DEG)))
|
||||
266153374) )
|
||||
|
||||
$ (REDUCED-SIN 45)
|
||||
|
||||
$ (REDUCED-COS 45)
|
||||
|
||||
CONTINUE
|
||||
Now for the somewhat tricky angle reduction functions:
|
||||
|
||||
$ (DEFUN SIN (ANGLE)
|
||||
((MINUSP ANGLE) (- (SIN (- ANGLE))))
|
||||
(SETQ ANGLE (DIVIDE (REM ANGLE 360) 45))
|
||||
(SIN-COS (CAR ANGLE) (CDR ANGLE)) )
|
||||
|
||||
$ (DEFUN COS (ANGLE)
|
||||
(SETQ ANGLE (DIVIDE (REM (ABS ANGLE) 360) 45))
|
||||
(SIN-COS (+ 2 (CAR ANGLE)) (CDR ANGLE)) )
|
||||
|
||||
$ (DEFUN SIN-COS (N45DEG RESID)
|
||||
((> N45DEG 3)
|
||||
(- (SIN-COS (- N45DEG 4) RESID)) )
|
||||
((ZEROP N45DEG) (REDUCED-SIN RESID))
|
||||
((EQL N45DEG 1) (REDUCED-COS (- 45 RESID)))
|
||||
((EQL N45DEG 2) (REDUCED-COS RESID))
|
||||
(REDUCED-SIN (- 45 RESID)) )
|
||||
|
||||
$ (SIN -390)
|
||||
|
||||
CONTINUE
|
||||
Now that we have a line-drawing routine and functions for finding the sine and
|
||||
cosine of an angle, we are ready to start implementing turtle graphics.
|
||||
|
||||
The current position of the turtle on the screen is stored by the integer
|
||||
global variables X-POS and Y-POS. Rather than using SETQ directly to assign
|
||||
values to X-POS and Y-POS, you can use the SETPOS command, defined as follows:
|
||||
|
||||
$ (DEFUN SETPOS (X Y)
|
||||
(SETQ X-POS X Y-POS Y) )
|
||||
|
||||
|
||||
CONTINUE
|
||||
In turtle graphics, the turtle always has a heading. The heading is measured
|
||||
in degrees measured clockwise from a line pointing straight up on the screen.
|
||||
The following shows the angles associated with the four major directions:
|
||||
|
||||
0
|
||||
|
|
||||
|
|
||||
270 <----+----> 90
|
||||
|
|
||||
|
|
||||
180
|
||||
|
||||
|
||||
CONTINUE
|
||||
The current heading of the turtle is the integer value of the global variable
|
||||
HEADING. The following TURN command is used to change the turtle's heading
|
||||
clockwise a given number of degrees relative to the current heading. To keep
|
||||
the heading within bounds, the heading is computed modulo 360 degrees.
|
||||
|
||||
$ (DEFUN TURN (ANGLE)
|
||||
(SETQ HEADING (REM (+ HEADING ANGLE) 360)) )
|
||||
|
||||
During this break, define the SETHEADING command. This is similar to the TURN
|
||||
command except that the heading is simply set to the absolute heading given as
|
||||
an argument to the command.
|
||||
|
||||
BREAK
|
||||
Our definition for the absolute SETHEADING command:
|
||||
|
||||
$ (DEFUN SETHEADING (ANGLE)
|
||||
(SETQ HEADING (REM ANGLE 360)) )
|
||||
|
||||
|
||||
CONTINUE
|
||||
We can control whether or not the turtle's "pen" is marking on the screen as
|
||||
it moves. If the control variable PENDOWN is T, the turtle marks as it moves;
|
||||
if PENDOWN is NIL, the turtle does not mark. Although we could use SETQ to
|
||||
make assignments to PENDOWN, it is more convenient to have functions for this
|
||||
purpose. During this break define the functions PENDOWN and PENUP:
|
||||
|
||||
BREAK
|
||||
Here are definitions for PENDOWN and PENUP:
|
||||
|
||||
$ (DEFUN PENDOWN ()
|
||||
(SETQ PENDOWN T) )
|
||||
|
||||
$ (DEFUN PENUP ()
|
||||
(SETQ PENDOWN NIL) )
|
||||
|
||||
|
||||
CONTINUE
|
||||
TURTLE is a convenient means of performing several successive turtle graphics
|
||||
commands. TURTLE first positions the turtle in the center of the screen
|
||||
pointing North (i.e. heading 0) and puts the pen down. DRAW is then called to
|
||||
switch to graphics mode and actually execute the commands.
|
||||
|
||||
$ (DEFUN TURTLE (NLAMBDA COMMANDS
|
||||
(SETPOS 0 0)
|
||||
(SETHEADING 0)
|
||||
(PENDOWN)
|
||||
(APPLY 'DRAW COMMANDS) ))
|
||||
|
||||
|
||||
CONTINUE
|
||||
Finally, here is the definition for the FORWARD command:
|
||||
|
||||
$ (DEFUN FORWARD (DISTANCE
|
||||
X-OLD Y-OLD )
|
||||
(SETQ X-OLD X-POS)
|
||||
(SETQ Y-OLD Y-POS)
|
||||
(INCQ X-POS (ROUND (* DISTANCE (SIN HEADING))))
|
||||
(INCQ Y-POS (ROUND (* DISTANCE (COS HEADING))))
|
||||
((NOT PENDOWN))
|
||||
(LINE X-OLD Y-OLD X-POS Y-POS) )
|
||||
|
||||
During this break, draw an equilateral triangle using the TURTLE command:
|
||||
|
||||
(TURTLE (FORWARD 10) (TURN 120)
|
||||
(FORWARD 20) (TURN 120)
|
||||
(FORWARD 20) (TURN 120)
|
||||
(FORWARD 10))
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
We have ignored the fact that "aspect-ratio" of the width to height of a
|
||||
character is not 1 on most sceens. For example, it is about 5/12 on the IBM
|
||||
PC in 80-character mode or about 5/6 on the IBM-PC in 40-character mode. For
|
||||
this reason, you may prefer the lower angular distortion of 40-column mode if
|
||||
available. (24 lines is the most severe cause of low-resolution, so half of
|
||||
the 80 columns is not much of a sacrifice.)
|
||||
|
||||
Character graphics tends to be most satisfactory if you ignore the aspect
|
||||
ratio. (You can always look at the screen from a compensatory slant!)
|
||||
However, we leave it as an exercise to account for the aspect ratio in the
|
||||
turtle graphics routines.
|
||||
|
||||
|
||||
CONTINUE
|
||||
Now we can begin a library of useful figures from which to compose more
|
||||
complicated figures. As a simple start, it is convenient to have a command
|
||||
for advancing a given distance then turning a given angle:
|
||||
|
||||
$ (DEFUN FORWARD-THEN-TURN (DISTANCE ANGLE)
|
||||
(FORWARD DISTANCE)
|
||||
(TURN ANGLE) )
|
||||
|
||||
|
||||
CONTINUE
|
||||
Next, it is useful to have a function that makes a polygon, ending up at the
|
||||
starting point and initial heading. A theorem that the resulting total turn
|
||||
of a closed figure is 0 modulo 360 helps us know when to stop:
|
||||
|
||||
$ (DEFUN POLY (SIDE ANGLE
|
||||
TOT-TURN)
|
||||
(SETQ TOT-TURN 0)
|
||||
(LOOP
|
||||
(FORWARD-THEN-TURN SIDE ANGLE)
|
||||
(SETQ TOT-TURN (REM (+ TOT-TURN ANGLE) 360))
|
||||
((ZEROP TOT-TURN)) ) )
|
||||
|
||||
During this break, experiment with POLY using various sides and angles. For
|
||||
example, try
|
||||
|
||||
(TURTLE (SETPOS -5 -10) (POLY 20 144))
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
Here is a challenging problem: See if you can write a CORNER-POLY function
|
||||
which draws a polygon that recursively has a similar half-sized polygon
|
||||
outside each corner until the sides are reduced to one pixel.
|
||||
|
||||
BREAK
|
||||
$ (DEFUN CORN-POL (SIDE ANGLE
|
||||
TOT-TURN)
|
||||
((> SIDE 1)
|
||||
(SETQ TOT-TURN 0)
|
||||
(LOOP
|
||||
(FORWARD SIDE)
|
||||
(CORN-POL (SHIFT SIDE -2) (- ANGLE))
|
||||
(TURN ANGLE)
|
||||
(SETQ TOT-TURN (REM (+ TOT-TURN ANGLE) 360))
|
||||
((ZEROP TOT-TURN)) ) ) )
|
||||
|
||||
Note the use of the function SHIFT in the definition. If <n> and <m> are
|
||||
integers and <m> is positive, (SHIFT n m) arithmetically shifts <n> LEFT <m>
|
||||
bits. If <m> is negative, SHIFT arithmetically shifts <n> RIGHT -<m> bits.
|
||||
SHIFT is used above to efficiently divide an integer by 2.
|
||||
|
||||
Try this call on CORN-POL for starters:
|
||||
|
||||
(TURTLE (SETPOS -5 -5) (CORN-POL 8 90))
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
A spiral is another useful component. Here is a definition that shrinks by
|
||||
subtracting a fixed increment from the side until the side becomes less than
|
||||
the increment:
|
||||
|
||||
$ (DEFUN SPIRAL (SIDE ANGLE INCR)
|
||||
(LOOP
|
||||
((< SIDE INCR))
|
||||
(FORWARD-THEN-TURN SIDE ANGLE)
|
||||
(DECQ SIDE INCR) ) )
|
||||
|
||||
During this break, try
|
||||
|
||||
(TURTLE (SETPOS -10 -12) (SPIRAL 23 90 1))
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
If SPIRAL is repeatedly called until the total turning reaches 0 modulo 360,
|
||||
then we will have a closed figure called a spirolateral. Define the function
|
||||
SPIROLATERAL and experimentally determine some attractive spirolaterals.
|
||||
|
||||
BREAK
|
||||
The spirolateral function:
|
||||
|
||||
$ (DEFUN SPIROLAT (SIDE ANGLE INCR
|
||||
TOT-TURN)
|
||||
(SETQ TOT-TURN 0)
|
||||
(LOOP
|
||||
(SPIRAL SIDE ANGLE INCR)
|
||||
(SETQ TOT-TURN (REM (+ TOT-TURN (* ANGLE (TRUNCATE SIDE INCR))) 360))
|
||||
((ZEROP TOT-TURN)) ) )
|
||||
|
||||
Try this:
|
||||
|
||||
(TURTLE (SETPOS 0 -6) (SPIROLAT 11 90 1))
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
Up till now we have been doing very low resolution, character "graphics". If
|
||||
you have a computer capable of higher resolution graphics, you may want to
|
||||
take advantage of this capability.
|
||||
|
||||
The graphics functions defined in this lesson work perfectly well for high
|
||||
resolution graphics if you make the following changes:
|
||||
|
||||
1. Redefine the point plotting function (DOT X-COORD Y-COORD) so it will
|
||||
properly interface with your graphics hardware.
|
||||
|
||||
2. Define the functions GRAPHICS-MODE and ALPHA-MODE to switch the screen
|
||||
between graphics and alpha modes.
|
||||
|
||||
3. If your computer is capable of color graphics, you can define a SETCOLOR
|
||||
command.
|
||||
|
||||
|
||||
CONTINUE
|
||||
The following definition for a plot function is for the IBM PC and IBM
|
||||
"look-alike" computers:
|
||||
|
||||
$ (DEFUN IBM-DOT (X-COORD Y-COORD)
|
||||
((AND (< -161 X-COORD 160)
|
||||
(< -101 Y-COORD 100) )
|
||||
(REGISTER 2 (+ 160 X-COORD))
|
||||
(REGISTER 3 (- 100 Y-COORD))
|
||||
(REGISTER 0 *COLOR*)
|
||||
(INTERRUPT 16) ) )
|
||||
|
||||
|
||||
If you are running muLISP on an IBM PC with a graphics display card (NOT a
|
||||
monochrome display card), issue the following command during this break:
|
||||
|
||||
(MOVD 'IBM-DOT 'DOT)
|
||||
|
||||
BREAK
|
||||
CLRSCRN
|
||||
The following definitions are for the IBM PC and IBM PC "look-alikes":
|
||||
|
||||
$ (DEFUN SETCOLOR (COLOR)
|
||||
(SETQ *COLOR* (+ 3071 (LENGTH (MEMBER COLOR
|
||||
'(WHITE RED GREEN BLACK))))) )
|
||||
|
||||
$ (SETCOLOR WHITE) ;Sets color to white
|
||||
|
||||
$ (DEFUN GRAPHICS-MODE () ;Sets up 320 x 200 color graphics mode
|
||||
(REGISTER 0 4)
|
||||
(INTERRUPT 16)
|
||||
(MAKE-WINDOW 0 0 25 40) )
|
||||
|
||||
$ (DEFUN ALPHA-MODE () ;Sets up 25 x 80 color alpha mode
|
||||
(REGISTER 0 3)
|
||||
(INTERRUPT 16)
|
||||
(CURSOR-LINES NIL)
|
||||
(MAKE-WINDOW 0 0 25 80) )
|
||||
|
||||
|
||||
CONTINUE
|
||||
The following definition for TURTLE is for the IBM PC and IBM "look-alikes":
|
||||
|
||||
$ (DEFUN TURTLE (NLAMBDA COMMANDS
|
||||
(IF (NEQ (CADDDR (MAKE-WINDOW)) 40) (GRAPHICS-MODE) )
|
||||
(MAKE-WINDOW 0 0 21 40)
|
||||
(SETPOS 0 0)
|
||||
(SETHEADING 0)
|
||||
(PENDOWN)
|
||||
(CATCH 'DRIVER (APPLY 'DRAW COMMANDS))
|
||||
(MAKE-WINDOW 21 0 4 40)
|
||||
(SET-CURSOR 3 0) ))
|
||||
|
||||
If you have modified DOT for high resolution graphics for your computer, try
|
||||
the following TURTLE command :
|
||||
|
||||
(TURTLE (SETPOS -30 15) (SPIROLAT 87 90 3))
|
||||
|
||||
BREAK
|
||||
$ (ALPHA-MODE)
|
||||
The use of recursion opens the door to really interesting designs and elegant
|
||||
graphics functions. The following function makes the intricate "C" curve:
|
||||
|
||||
$ (DEFUN C-CURVE (DEPTH)
|
||||
((ZEROP DEPTH)
|
||||
(FORWARD *LENGTH*) )
|
||||
(TURN 45)
|
||||
(C-CURVE (SUB1 DEPTH))
|
||||
(TURN -90)
|
||||
(C-CURVE (SUB1 DEPTH))
|
||||
(TURN 45) )
|
||||
|
||||
$ (SETQ *LENGTH* 3)
|
||||
|
||||
Try this pattern: (TURTLE (TURN 270) (SETPOS 60 -30) (C-CURVE 11))
|
||||
|
||||
BREAK
|
||||
$ (ALPHA-MODE)
|
||||
The following only slightly more complicated function draws the famous
|
||||
"Dragon" curve:
|
||||
|
||||
$ (DEFUN D-CURVE (DEPTH FLAG)
|
||||
((ZEROP DEPTH)
|
||||
(FORWARD *LENGTH*) )
|
||||
(IF FLAG (TURN 45) (TURN -45))
|
||||
(D-CURVE (SUB1 DEPTH) T)
|
||||
(IF FLAG (TURN -90) (TURN 90))
|
||||
(D-CURVE (SUB1 DEPTH) NIL)
|
||||
(IF FLAG (TURN 45) (TURN -45)) )
|
||||
|
||||
$ (SETQ *LENGTH* 3)
|
||||
|
||||
Try this pattern: (TURTLE (TURN 90) (SETPOS -60 0) (D-CURVE 11))
|
||||
|
||||
BREAK
|
||||
$ (ALPHA-MODE)
|
||||
We have barely scratched the surface of what can be accomplished with turtle
|
||||
graphics. If you would like to learn more, there are many good books on LOGO
|
||||
and turtle graphics. One of the more advanced and thorough is "Turtle
|
||||
Graphics" by Harold Abelson and Andrea A. diSessa, (MIT Press, 1980).
|
||||
|
||||
As a convenience to you, all the functions defined in this lesson have been
|
||||
included in the muLISP source file GRAPHICS.LIB.
|
||||
|
||||
This concludes muLISP lesson #6.
|
||||
|
||||
|
||||
CONTINUE
|
||||
$ (RDS)
|
||||
|
||||
128
Microsoft muLISP-86 v51/MULISP83.LSP
Normal file
128
Microsoft muLISP-86 v51/MULISP83.LSP
Normal file
@ -0,0 +1,128 @@
|
||||
; File: MULISP83.LSP (C) 12/29/85 Soft Warehouse, Inc.
|
||||
|
||||
; muLISP-83 Compatibility File
|
||||
|
||||
|
||||
; This file makes it possible for muLISP-86 to run muLISP-83 programs
|
||||
; with no or only a few changes required. WARNING: This file should
|
||||
; NOT be read into a running muLISP-86 system more than once.
|
||||
|
||||
(SETQ *READ-UPCASE* NIL) ;Turns off auto uppercase conversion.
|
||||
(SETQ *PRINT-ESCAPE* NIL) ;Turns off printing of escape chars.
|
||||
(SETQ PUTD NIL) ;Turns on full D-code condensing.
|
||||
|
||||
(COPY-CHAR-TYPE '\" '\|) ;Make " a multiple escape char.
|
||||
|
||||
(CSMEMORY 849 (ASCII '\")) ;Display multiple escape char as ".
|
||||
|
||||
(COPY-CHAR-TYPE '\| 'A) ;Make | not a multiple escape char.
|
||||
|
||||
(COPY-CHAR-TYPE (ASCII 12) 'A) ;Make <page> a constituent char.
|
||||
|
||||
(COPY-CHAR-TYPE '"," '" ") ;Make , a whitespace char.
|
||||
|
||||
;Set up muLISP-83 break chars.
|
||||
(SET-BREAK-CHARS (CONS (ASCII 26)
|
||||
'(! $ & "(" ")" * + "," - "." / : < = > ? @ "[" \\ "]" ^ _ ` { | } ~)))
|
||||
|
||||
;Make % a comment delimiter.
|
||||
(SET-MACRO-CHAR '"%" '(LAMBDA () (PEEK-CHAR '"%") (READ-CHAR)) 'COMMENT)
|
||||
|
||||
;Make ' a NONterminating macro char.
|
||||
(SET-MACRO-CHAR '"'" (GET-MACRO-CHAR '"'") T)
|
||||
|
||||
(PUTD 'READ-LST (GET-MACRO-CHAR '"("))
|
||||
|
||||
(PUTD 'READ-BRACKET '(LAMBDA (EXPN)
|
||||
(SETQ EXPN (READ-LST))
|
||||
((EQ (PEEK-CHAR 'T) '"]")
|
||||
(READ-CHAR) EXPN)
|
||||
(CONS EXPN (READ-BRACKET)) ))
|
||||
|
||||
(SET-MACRO-CHAR '"[" (GETD READ-BRACKET)) ;Make [ a super-parenthesis.
|
||||
|
||||
(MOVD 'SYMBOLP 'NAME)
|
||||
(MOVD 'EQL 'EQ)
|
||||
(MOVD 'IDENTITY 'NONNULL)
|
||||
(MOVD '< 'LESSP)
|
||||
(MOVD '> 'GREATERP)
|
||||
(MOVD '+ 'PLUS)
|
||||
(MOVD '- 'DIFFERENCE)
|
||||
(MOVD '- 'MINUS)
|
||||
(MOVD '* 'TIMES)
|
||||
(MOVD 'CLEAR-SCREEN 'CLRSCRN)
|
||||
(MOVD 'SET-CURSOR 'CURSOR)
|
||||
|
||||
|
||||
; WARNING: The '86 functions TRUNCATE, REM, and DIVIDE return different
|
||||
; values than the '83 functions QUOTIENT, REMAINDER, and DIVIDE when
|
||||
; given negative arguments. See the Reference Manual for details.
|
||||
|
||||
(MOVD 'TRUNCATE 'QUOTIENT)
|
||||
(MOVD 'REM 'REMAINDER)
|
||||
|
||||
(MOVD 'MEMBER 'MEMBER-AUX)
|
||||
(PUTD 'MEMBER '(LAMBDA (ITEM LST)
|
||||
(MEMBER-AUX ITEM LST 'EQUAL) ))
|
||||
|
||||
(MOVD 'ASSOC 'ASSOC-AUX)
|
||||
(PUTD 'ASSOC '(LAMBDA (ITEM LST)
|
||||
(ASSOC-AUX ITEM LST 'EQUAL) ))
|
||||
|
||||
(MOVD 'APPEND 'APPEND-AUX)
|
||||
(PUTD 'APPEND '(LAMBDA LST
|
||||
((NULL (CDR LST))
|
||||
(COPY-LIST (CAR LST)) )
|
||||
(APPLY 'APPEND-AUX LST) ))
|
||||
|
||||
(PUTD 'NTH '(LAMBDA (ARG1 ARG2)
|
||||
((NUMBERP ARG2)
|
||||
(NTHCDR (SUB1 ARG2) ARG1) )
|
||||
(CAR (NTHCDR ARG1 ARG2)) ))
|
||||
|
||||
(MOVD 'SUBSTRING 'SUBSTRING-AUX)
|
||||
(PUTD 'SUBSTRING '(LAMBDA (ARG N M)
|
||||
((NUMBERP N)
|
||||
((NUMBERP M)
|
||||
(SUBSTRING-AUX ARG (SUB1 N) (SUB1 M)) )
|
||||
(SUBSTRING-AUX ARG (SUB1 N)) )
|
||||
((NUMBERP M)
|
||||
(SUBSTRING-AUX ARG N (SUB1 M)) )
|
||||
(SUBSTRING-AUX ARG) ))
|
||||
|
||||
(MOVD 'FINDSTRING 'FINDSTRING-AUX)
|
||||
(PUTD 'FINDSTRING '(LAMBDA (ARG1 ARG2 N)
|
||||
( ((NUMBERP N)
|
||||
(DECQ N) ) )
|
||||
(SETQ N (FINDSTRING-AUX ARG1 ARG2 N))
|
||||
((NUMBERP N)
|
||||
(ADD1 N) )
|
||||
N ))
|
||||
|
||||
(PUTD 'READCH '(LAMBDA (FLAG
|
||||
READ-CHAR )
|
||||
(SETQ READ-CHAR READCH)
|
||||
(SETQ RATOM (READ-CHAR FLAG))
|
||||
((LESSP 47 (ASCII RATOM) 58)
|
||||
(SETQ RATOM (DIFFERENCE (ASCII RATOM) 48)) )
|
||||
((NULL READ)
|
||||
(SETQ RATOM (STRING-UPCASE RATOM)) )
|
||||
RATOM ))
|
||||
|
||||
(PUTD 'READP '(LAMBDA (READ-CHAR)
|
||||
(SETQ READ-CHAR READCH)
|
||||
(LISTEN FLAG) ))
|
||||
|
||||
(PUTD RADIX '(LAMBDA (NUM)
|
||||
(PROG1 *READ-BASE* (SETQ *READ-BASE* NUM *PRINT-BASE* NUM)) ))
|
||||
|
||||
(MOVD 'UNDEFINED 'UNDEFINED-AUX)
|
||||
(PUTD 'UNDEFINED '(LAMBDA #LST#
|
||||
((ATOM (CAR #LST#))
|
||||
((EQ (CAR #LST#) (CAAR #LST#))
|
||||
(APPLY UNDEFINED-AUX #LST#) )
|
||||
(EVAL (CONS (CAAR #LST#) (CDR #LST#))) )
|
||||
(APPLY UNDEFINED-AUX #LST#) ))
|
||||
|
||||
(RDS)
|
||||
|
||||
46
Microsoft muLISP-86 v51/README
Normal file
46
Microsoft muLISP-86 v51/README
Normal file
@ -0,0 +1,46 @@
|
||||
This is a summary of muLISP-86 features not yet incorporated into
|
||||
the Reference Manual:
|
||||
|
||||
The file HELP.LSP provides a help facility for muLISP primitives.
|
||||
After it is read in, commands of the form (HELP name) or (? name)
|
||||
show <name>'s arguments, primitive type, and page number in
|
||||
Chapter 5 of the Reference Manual.
|
||||
|
||||
The file STRUCTUR.LSP contains a structure facility (DEFSTRUCT) and
|
||||
an array facility (MAKE-ARRAY, AREF, ARRAY-RANK, ARRAY-DIMENSION,
|
||||
ARRAY-DIMENSIONS, ARRAY-TOTAL-SIZE, and ARRAY-IN-BOUNDS-P).
|
||||
See the file and Chapters 17 and 19 of Common LISP by Steele for
|
||||
documentation.
|
||||
|
||||
The function DOS, defined in COMMON.LSP, simplifies the calling of
|
||||
the MS-DOS command processor. For example: (DOS "DIR B:/W").
|
||||
|
||||
The function GENSYM, defined in COMMON.LSP, creates new symbols.
|
||||
(GENSYM) returns a new symbol. If <n> is a nonnegative integer,
|
||||
(GENSYM n) sets the gensym counter to <n>. (GENSYM symbol) sets
|
||||
the gensym prefix to <symbol>.
|
||||
|
||||
A "backquote" macro character, defined in COMMON.LSP, facilitates
|
||||
defining macros using DEFMACRO. See the file and pages 349-351 of
|
||||
Common LISP by Steele for documentation.
|
||||
|
||||
The functions STRING-TRIM, STRING-RIGHT-TRIM, and STRING-LEFT-TRIM,
|
||||
defined in MULISP.COM, can now accept either a list or a symbol
|
||||
as its first argument (in accordance with Common LISP).
|
||||
|
||||
The function STACK-LIST, defined in MULISP.COM, returns a list of
|
||||
the values currently on the muLISP variable stack.
|
||||
|
||||
The muLISP editor command Ctrl-Q L repeats the last search and
|
||||
replace command until the end of the text is reached.
|
||||
|
||||
If the muLISP editor control variable *CASE-IGNORE* is nonNIL,
|
||||
case is ignored when searching for a string.
|
||||
|
||||
The muLISP editor variable *WINDOW-SHAPE* controls the initial
|
||||
dimensions of the edit window. F for full screen, V for vertical
|
||||
split, H for horizontal split.
|
||||
|
||||
A native code compiler for muLISP is now available from Soft
|
||||
Warehouse, Inc. Write Soft Warehouse for details.
|
||||
|
||||
49
Microsoft muLISP-86 v51/SIEVE.LSP
Normal file
49
Microsoft muLISP-86 v51/SIEVE.LSP
Normal file
@ -0,0 +1,49 @@
|
||||
; BYTE magazine's Sieve benchmark
|
||||
|
||||
(setq size 8190)
|
||||
(setq a (make-array (+ size 1) :initial-element 0 ))
|
||||
(setq count 0)
|
||||
|
||||
(defun kloop(k prime)
|
||||
(loop
|
||||
(when (> k size) (return 0))
|
||||
(setf (aref a k) nil)
|
||||
(setq k (+ k prime))
|
||||
)
|
||||
)
|
||||
|
||||
(defun runsieve() (prog ()
|
||||
(setq i 0)
|
||||
(setq count 0)
|
||||
_nexti_
|
||||
(cond ((<= i size)
|
||||
(setf (aref a i) t)
|
||||
(setq i (add1 i))
|
||||
(go _nexti_))
|
||||
)
|
||||
|
||||
(setq i 0)
|
||||
_nexti2_
|
||||
(cond ((<= i size)
|
||||
(cond ((aref a i)
|
||||
(setq prime (+ i i 3))
|
||||
(kloop (+ i prime) prime)
|
||||
(setq count (add1 count)))
|
||||
)
|
||||
(setq i (add1 i))
|
||||
(go _nexti2_))
|
||||
)
|
||||
))
|
||||
|
||||
(defun main() (prog ()
|
||||
(princ "running...")
|
||||
(setq startTime (time))
|
||||
|
||||
(dotimes (z 10) (runsieve))
|
||||
(princ "count: ") (princ count)
|
||||
(princ "elapsed hundredths of a second: ") (- (time) startTime)
|
||||
))
|
||||
|
||||
(main)
|
||||
(system)
|
||||
|
||||
BIN
Microsoft muLISP-86 v51/STATE.SYS
Normal file
BIN
Microsoft muLISP-86 v51/STATE.SYS
Normal file
Binary file not shown.
583
Microsoft muLISP-86 v51/STRUCTUR.LSP
Normal file
583
Microsoft muLISP-86 v51/STRUCTUR.LSP
Normal file
@ -0,0 +1,583 @@
|
||||
; File: STRUCTUR.LSP (C) 12/25/85 Soft Warehouse, Inc.
|
||||
|
||||
; COMMON.LSP must also be read in to use the functions in this file.
|
||||
|
||||
|
||||
; muLISP Array Facility
|
||||
|
||||
; The muLISP array facility provides a subset of the Common LISP array
|
||||
; capability (see Chapter 17 of Common LISP, The Language by Guy L.
|
||||
; Steele Jr. [1984]). Arrays are realized as 3-element lists of the form:
|
||||
|
||||
; (ARRAY <array-contents> <dims>)
|
||||
|
||||
; where <array-contents> is a list of lists "compatible in length"
|
||||
; with <dims>, and <dims> is a list of zero or more positive integers.
|
||||
; Thus, arrays carry type and dimension information around with them
|
||||
; for fast array bounds checking.
|
||||
|
||||
|
||||
; Array Creation (see Steele, Section 17.1):
|
||||
|
||||
; (MAKE-ARRAY <dimensions> {<option>}+) creates an array of dimensions
|
||||
; <dimensions>.
|
||||
|
||||
; <dimensions> can be NIL, <dim>, or (<dim1> ... <dimn>). <dim> must be
|
||||
; a POSITIVE integer (Common LISP only requires <dim> to be a
|
||||
; NON-NEGATIVE integer).
|
||||
|
||||
; <option> is an array creation option of the form:
|
||||
; <keyword> <option-specifications>
|
||||
; where <keyword> is one of the array option keywords described below.
|
||||
; (Note: Keywords may be used in upper or lower case.)
|
||||
|
||||
; :INITIAL-ELEMENT expression
|
||||
; This option sets the initial value of each array element to <expression>.
|
||||
; If the :INITIAL-ELEMENT option is not given, the initial value of each
|
||||
; array element will be NIL.
|
||||
|
||||
; :INITIAL-CONTENTS expression
|
||||
; This option sets the initial contents of the array to a COPY of the
|
||||
; elements of <expression>, if <expression> is "compatible in length"
|
||||
; with the dimensions of the array (i.e. if the length of <expression>
|
||||
; is equal to the first dimension of the array and each element of
|
||||
; <expression> is "compatible in length" with the remaining dimensions
|
||||
; of the array). If the :INITIAL-CONTENTS option is not given, each
|
||||
; array element will be determined in accordance with the
|
||||
; :INITIAL-ELEMENT option.
|
||||
|
||||
; The Common LISP array creation options :ELEMENT-TYPE, :ADJUSTABLE,
|
||||
; :FILL-POINTER, :DISPLACED-TO, and :DISPLACED-INDEX-OFFSET are NOT
|
||||
; supported.
|
||||
|
||||
; MAKE-ARRAY can generate the following error breaks:
|
||||
|
||||
; Dimension Error: indicates that the dimension specification is
|
||||
; neither NIL, a positive integer, nor a list of positive integers.
|
||||
|
||||
; Incompatible Length: indicates that the value specified for
|
||||
; the :INITIAL-CONTENTS is NOT "compatible in length" with the
|
||||
; dimensions of the array.
|
||||
|
||||
|
||||
(DEFMACRO MAKE-ARRAY (DIMS . OPTIONS)
|
||||
(LIST 'MAKE-ARRAY-AUX DIMS (LIST 'QUOTE OPTIONS)) )
|
||||
|
||||
(DEFUN MAKE-ARRAY-AUX (DIMS OPTIONS)
|
||||
(IF (NUMBERP DIMS) (SETQ DIMS (LIST DIMS)))
|
||||
((AND (LISTP DIMS)
|
||||
(EVERY '(LAMBDA (N) (AND (INTEGERP N) (PLUSP N)))
|
||||
DIMS) )
|
||||
(LET ((conts (EVAL (CADR (MEMBER ':INITIAL-CONTENTS OPTIONS)))) )
|
||||
((NULL conts)
|
||||
(LIST 'ARRAY
|
||||
(MAKE-ARRAY-CONTENTS DIMS
|
||||
(EVAL (CADR (MEMBER ':INITIAL-ELEMENT OPTIONS))))
|
||||
DIMS) )
|
||||
((ARRAY-CONTENTS-P DIMS conts)
|
||||
(LIST 'ARRAY
|
||||
(COPY-ARRAY-CONTENTS DIMS conts)
|
||||
DIMS) )
|
||||
(BREAK (LIST* 'MAKE-ARRAY DIMS OPTIONS) "Incompatible Length") ) )
|
||||
(BREAK (LIST* 'MAKE-ARRAY DIMS OPTIONS) "Dimension Error") )
|
||||
|
||||
(DEFUN MAKE-ARRAY-CONTENTS (DIMS INITELEM)
|
||||
; Creates an array contents structure "compatible in length" with DIMS,
|
||||
; and with INITELEM as the value of each element.
|
||||
((NULL (CDR DIMS))
|
||||
(MAKE-LIST (CAR DIMS) INITELEM) )
|
||||
(LET ((dim (CAR DIMS))
|
||||
(aconts NIL) )
|
||||
(LOOP
|
||||
((ZEROP dim) aconts)
|
||||
(PUSH (MAKE-ARRAY-CONTENTS (CDR DIMS) INITELEM) aconts)
|
||||
(DECQ dim) ) ) )
|
||||
|
||||
(DEFUN ARRAY-CONTENTS-P (DIMS ACONTS)
|
||||
; Tests whether ACONTS is a list "compatible in length" with DIMS.
|
||||
((NULL DIMS) T)
|
||||
((= (LENGTH ACONTS) (CAR DIMS))
|
||||
(EVERY '(LAMBDA (ELEM) (ARRAY-CONTENTS-P (CDR DIMS) ELEM) )
|
||||
ACONTS) ) )
|
||||
|
||||
(DEFUN COPY-ARRAY-CONTENTS (DIMS ACONTS)
|
||||
; Copies ACONTS in accordance with DIMS. Elements of ACONTS outside
|
||||
; the scope of DIMS (i.e. actual elements of the array) are NOT copied.
|
||||
((NULL (CDR DIMS))
|
||||
(COPY-LIST ACONTS) )
|
||||
(MAPCAR '(LAMBDA (ELEM) (COPY-ARRAY-CONTENTS (CDR DIMS) ELEM) )
|
||||
ACONTS) )
|
||||
|
||||
|
||||
; Array Access (see Steele, Section 17.2):
|
||||
|
||||
; If <subscript1> ... <subscriptn> are non-negative integers,
|
||||
; (AREF <array> <subscript1> ... <subscriptn>) returns the specifed
|
||||
; element of <array>; and
|
||||
; (SETF (AREF <array> <subscript1> ... <subscriptn>) <expr>) sets the
|
||||
; specified element of <array> to the value of <expr>.
|
||||
|
||||
; Note that AREF contains NO array bounds error checking. This provides
|
||||
; good execution speed, but means that such checking must be done by the
|
||||
; user using the function ARRAY-IN-BOUNDS-P, defined below.
|
||||
|
||||
(DEFMACRO AREF (ARRAY . SUBSCRIPTS)
|
||||
(SETQ ARRAY (LIST 'CADR ARRAY))
|
||||
(LOOP
|
||||
((NULL SUBSCRIPTS) ARRAY)
|
||||
(SETQ ARRAY (LIST 'NTH (POP SUBSCRIPTS) ARRAY)) ) )
|
||||
|
||||
|
||||
; Array Information (see Steele, Section 17.3):
|
||||
|
||||
(DEFUN ARRAY-RANK (ARRAY)
|
||||
; Returns the "rank" of ARRAY.
|
||||
(LENGTH (CADDR ARRAY)) )
|
||||
|
||||
(DEFUN ARRAY-DIMENSION (ARRAY AXISNUMBER)
|
||||
; Returns the dimension of ARRAY along the AXISNUMBER axis (where
|
||||
; 0 is the first axis of any array).
|
||||
(NTH AXISNUMBER (CADDR ARRAY)) )
|
||||
|
||||
(DEFUN ARRAY-DIMENSIONS (ARRAY)
|
||||
; Returns the list of dimensions of ARRAY.
|
||||
(CADDR ARRAY) )
|
||||
|
||||
(DEFUN ARRAY-TOTAL-SIZE (ARRAY)
|
||||
; Returns the total number of elements in ARRAY.
|
||||
(REDUCE '* (CADDR ARRAY)) )
|
||||
|
||||
(DEFUN ARRAY-IN-BOUNDS-P AREFSPEC
|
||||
; Tests whether AREFSPEC, an array/subscripts specification of
|
||||
; the form used in AREF, is within the bounds of the array.
|
||||
(EVERY '(LAMBDA (I B) (AND (INTEGERP I) (< -1 I B)))
|
||||
(CDR AREFSPEC)
|
||||
(CADDAR AREFSPEC)) )
|
||||
|
||||
|
||||
; muLISP Structure Facility
|
||||
|
||||
; The muLISP structure facility provides a subset of the Common LISP
|
||||
; structure capability (see Chapter 19 of Common LISP, The Language
|
||||
; by Guy L. Steele Jr. [1984]). Named structures are realized as lists
|
||||
; of the form:
|
||||
|
||||
; (<structname> <slot-1> <slot-2> ... <slot-n>)
|
||||
|
||||
; Unnamed structures are realized as lists of the form:
|
||||
|
||||
; (<slot-1> <slot-2> ... <slot-n>)
|
||||
|
||||
; All structure functions -- constructors, accessors, copiers, and
|
||||
; predicates -- are implemented as MACROs. This yields good execution
|
||||
; speed, and integrates nicely with the SETF implementation. However,
|
||||
; there are some costs:
|
||||
; 1. Structures must be defined BEFORE their functions are used.
|
||||
; 2. Structure functions cannot be APPLYed, FUNCALLed, mapped down
|
||||
; lists, etc., by themselves. This can be accomplished by
|
||||
; "wrapping" the function in a LAMBDA; for example, instead of
|
||||
; (MAPCAR 'SLOT-NAME X) use (MAPCAR '(LAMBDA (S) (SLOT-NAME S)) X).
|
||||
; 3. Redefining a structure will NOT cause all uses of structure
|
||||
; functions to be redefined (i.e. re-expanded) UNLESS the
|
||||
; control variable MACROEXPAND is NIL. For this reason,
|
||||
; it is recommended that MACROEXPAND be set to NIL during
|
||||
; program development. This will slow down execution speed
|
||||
; during development, but make modifications much easier.
|
||||
|
||||
; The structure functions contain NO execution or expansion time error
|
||||
; checking. This provides good execution speed, but means that any
|
||||
; error checking needed must be supplied by the user.
|
||||
|
||||
; Structure definition components -- options, slot names, slot values,
|
||||
; a :NAMED flag, and structure functions (MACROs) -- are stored on the
|
||||
; property list of the structure's name. In addition, a list of the
|
||||
; structures supported is stored on the property list of each structure
|
||||
; function. (See the functions PUTSTRUCT and REMSTRUCT below).
|
||||
|
||||
|
||||
; Structure Definition (see Steele, Section 19.2):
|
||||
|
||||
; (DEFSTRUCT <name-and-options> {<slot-description>}+) creates a
|
||||
; structure data type. <name-and-options> has the form <name> or
|
||||
; (<name> {<option>}+), where <name> is a symbol and <option> is a
|
||||
; DEFSTRUCT option (see below). Each <slot-description> has the form
|
||||
; <slotname> or (<slotname> <expr>), where <slotname> is a symbol
|
||||
; and <expr> is any evaluable muLISP expression. Note that "slot
|
||||
; options" are NOT supported.
|
||||
|
||||
|
||||
; Defstruct Options (see Steele, Section 19.5):
|
||||
|
||||
; DEFSTRUCT options have the form <keyword> or
|
||||
; (<keyword> . <option-specifications>) where <keyword> is a defstruct
|
||||
; option keyword (Note: Keywords may be used in upper or lower case).
|
||||
|
||||
; :CONC-NAME prefix
|
||||
; This option modifies the default prefix naming of <slotname>'s
|
||||
; accessor function as follows:
|
||||
; 1. If the :CONC-NAME option is not given, the accessor function
|
||||
; will be named (PACK* <structname> "-" <slotname>).
|
||||
; 2. If <prefix> is a nonNIL symbol, the accessor function will be
|
||||
; named (PACK* <prefix> <slotname>).
|
||||
; 3. If <prefix> is NIL, the accessor function will be named
|
||||
; <slotname> (i.e. with NO prefix).
|
||||
|
||||
; :CONSTRUCTOR consname [arglist]
|
||||
; This option modifies the default naming of the standard keyword
|
||||
; constructor function and specifies additional positional
|
||||
; constructor functions as follows:
|
||||
; 1. If the :CONSTRUCTOR option is not given, a standard keyword
|
||||
; constructor named (PACK* "MAKE-" <structname>) will be provided.
|
||||
; 2. If <consname> is a nonNIL symbol, a standard keyword
|
||||
; constructor named <consname> will be provided.
|
||||
; 3. If <consname> is NIL, NO keyword constructor will be provided.
|
||||
; 4. If <consname> is a symbol and <arglist> is a list of names of
|
||||
; slots of the structure, a positional constructor named
|
||||
; <consname> will be provided.
|
||||
; (Note that more than one :CONSTRUCTOR option can be included in a
|
||||
; structure definition.)
|
||||
|
||||
; :COPIER copyname
|
||||
; This option modifies the default naming of the standard copier
|
||||
; function as follows:
|
||||
; 1. If the :COPIER option is not given, a standard copier named
|
||||
; (PACK* "COPY-" <structname>) will be provided.
|
||||
; 2. If <copyname> is a nonNIL symbol, a standard copier named
|
||||
; <copyname> will be provided.
|
||||
; 3. If <copyname> is NIL, NO copier will be provided.
|
||||
|
||||
; :PREDICATE predname
|
||||
; This option modifies the default naming of the standard predicate
|
||||
; function of named structures as follows:
|
||||
; 1. If the :PREDICATE option is not given, a standard predicate
|
||||
; named (PACK* <structname> "-P") will be provided.
|
||||
; 2. If <predname> is a nonNIL symbol, a standard predicate named
|
||||
; <predname> will be provided.
|
||||
; 3. If <predname> is NIL, NO predicate will be provided.
|
||||
|
||||
; :INCLUDE inclstruct {<slotdescrip>}+
|
||||
; This option includes the slots of a previously defined structure
|
||||
; in the structure being defined (the structure being defined
|
||||
; becomes an extension and specialization of the :INCLUDEd structure)
|
||||
; as follows:
|
||||
; 1. If the :INCLUDE option is not given, no other structure will
|
||||
; be included.
|
||||
; 2. If <inclstruct> is a previously defined structure, the structure
|
||||
; being defined will include the slots of <inclstruct>.
|
||||
; 3. If <inclstruct> is a previously defined structure and each
|
||||
; <slotdescrip> describes a slot in <inclstruct>, the structure
|
||||
; being defined will include the slots of <inclstruct>, but with
|
||||
; original default values overridden by {<slotdescrip>}+.
|
||||
; (Note that included structures must be :NAMED or not :NAMED
|
||||
; consistently with the structure being defined.)
|
||||
|
||||
; :TYPE LIST
|
||||
; This option used in conjunction with the :NAMED option forces a
|
||||
; particular representation for the structure being defined as follows:
|
||||
; 1. If the :TYPE option is not given, the structure being defined
|
||||
; will be represented as a list and will be :NAMED.
|
||||
; 2. If the :TYPE option is given, the structure being defined
|
||||
; will be represented as a list and will NOT be :NAMED, unless
|
||||
; the structure definition explicitly specifies the :NAMED option.
|
||||
; (Note that only the type LIST is valid.)
|
||||
|
||||
; :NAMED
|
||||
; This option used in conjunction with the :TYPE option forces a
|
||||
; particular representation for the structure being defined as follows:
|
||||
; 1. If the :NAMED option is not given, the structure being defined
|
||||
; will be :NAMED unless an explicit :TYPE option is specified.
|
||||
; 2. If the :NAMED option is given, the structure being defined will
|
||||
; be :NAMED irrespective of any :TYPE specifications.
|
||||
|
||||
; The Common LISP DEFSTRUCT options :PRINT-FUNCTION and :INITIAL-OFFSET
|
||||
; are NOT supported.
|
||||
|
||||
|
||||
; DEFSTRUCT can generate the following error breaks:
|
||||
|
||||
; Nonsymbolic Argument: indicates that a nonsymbol was given as the
|
||||
; name for a structure or a slot in the structure.
|
||||
|
||||
; Unsupported Option: indicates that an unsupported DEFSTRUCT option
|
||||
; was given.
|
||||
|
||||
; Unnamed Structure: indicates that a predicate option was given for
|
||||
; an unnamed structure.
|
||||
|
||||
; Undefined Structure: indicates that the name of an undefined
|
||||
; structure was given for inclusion in a structure.
|
||||
|
||||
; Include Error: indicates that a named structure was given for inclusion
|
||||
; in an unnamed structure, or that an unnamed structure was given for
|
||||
; inclusion in a named structure.
|
||||
|
||||
; Incompatible definition: indicates that a definition for a function
|
||||
; is incompatible with the existing definition of the function.
|
||||
|
||||
|
||||
(DEFMACRO DEFSTRUCT (STRUCTSPEC . SLOTSPECS)
|
||||
(LIST 'DEFSTRUCT-AUX
|
||||
(LIST 'QUOTE STRUCTSPEC)
|
||||
(LIST 'QUOTE SLOTSPECS)) )
|
||||
|
||||
(DEFUN DEFSTRUCT-AUX (STRUCTSPEC SLOTSPECS)
|
||||
(LET* ((name (GET-STRUCT-NAME STRUCTSPEC))
|
||||
(options (GET-STRUCT-OPTIONS name STRUCTSPEC))
|
||||
(slotnams (GET-STRUCT-SLOT-NAMES name SLOTSPECS))
|
||||
(slotvals (GET-STRUCT-SLOT-VALUES name SLOTSPECS))
|
||||
(named? (OR (ASSOC ':NAMED options)
|
||||
(NOT (ASSOC ':TYPE options))) ) )
|
||||
(LET ((istruct (ASSOC ':INCLUDE options)) )
|
||||
((CHECK-INCLUDED-STRUCT name istruct named?)
|
||||
(SETQ slotnams
|
||||
(APPEND (GET (CADR istruct) 'STRUCT-SLOTNAMES)
|
||||
slotnams))
|
||||
(SETQ slotvals
|
||||
(MAPCAR '(LAMBDA (SNAM SVAL)
|
||||
((CADR (ASSOC SNAM (CDDR istruct))) )
|
||||
SVAL)
|
||||
slotnams
|
||||
(APPEND (GET (CADR istruct) 'STRUCT-SLOTVALS)
|
||||
slotvals))) ) )
|
||||
(PUTSTRUCT name options slotnams slotvals named?
|
||||
(CHECK-STRUCT-MACDEFS name
|
||||
(APPEND (FORM-STRUCT-CONSTRUCTORS name options slotnams
|
||||
slotvals named?)
|
||||
(FORM-STRUCT-ACCESSORS name options slotnams
|
||||
named?)
|
||||
(FORM-STRUCT-PREDICATE name options named?)
|
||||
(FORM-STRUCT-COPIER name options)))) ) )
|
||||
|
||||
|
||||
(DEFUN GET-STRUCT-NAME (STRUCTSPEC)
|
||||
; Extracts and returns the structure name specification from STRUCTSPEC,
|
||||
; verifying that it is a symbol.
|
||||
(LET ((stnam (IF (CONSP STRUCTSPEC) (CAR STRUCTSPEC) STRUCTSPEC) ) )
|
||||
((SYMBOLP stnam) stnam)
|
||||
(BREAK (LIST* 'DEFSTRUCT STRUCTSPEC SLOTSPECS) "Nonsymbolic Argument") ) )
|
||||
|
||||
(DEFUN GET-STRUCT-OPTIONS (NAME STRUCTSPEC)
|
||||
; Extracts the structure option specifications from STRUCTSPEC, verifying
|
||||
; that each is a supported option. Collects and returns the options in
|
||||
; a uniform "a-list" format.
|
||||
((ATOM STRUCTSPEC) NIL)
|
||||
(MAPCAR '(LAMBDA (OPT)
|
||||
(LET ((optnam (IF (CONSP OPT) (CAR OPT) OPT) ) )
|
||||
((AND (SYMBOLP optnam)
|
||||
(MEMBER (SETQ optnam (STRING-UPCASE optnam))
|
||||
'(:CONC-NAME :CONSTRUCTOR :COPIER
|
||||
:PREDICATE :INCLUDE :TYPE :NAMED)) )
|
||||
(CONS optnam (IF (CONSP OPT) (CDR OPT))) )
|
||||
(BREAK (LIST* 'DEFSTRUCT STRUCTSPEC SLOTSPECS)
|
||||
"Unsupported Option") ) )
|
||||
(CDR STRUCTSPEC)) )
|
||||
|
||||
(DEFUN GET-STRUCT-SLOT-NAMES (NAME SLOTSPECS)
|
||||
; Extracts the structure slot names from SLOTSPECS, verifying that each
|
||||
; is a symbol. Returns a list of the slot names.
|
||||
(MAPCAR '(LAMBDA (SLOT)
|
||||
(LET ((snam (IF (CONSP SLOT) (CAR SLOT) SLOT)) )
|
||||
((SYMBOLP snam) snam)
|
||||
(BREAK (LIST* 'DEFSTRUCT STRUCTSPEC SLOTSPECS)
|
||||
"Nonsymbolic Argument") ) )
|
||||
SLOTSPECS) )
|
||||
|
||||
(DEFUN GET-STRUCT-SLOT-VALUES (NAME SLOTSPECS)
|
||||
; Extracts the structure slot values from SLOTSPECS, supplying NIL as
|
||||
; the value for any slot without a specified value. Returns a list of
|
||||
; the slot values.
|
||||
(MAPCAR '(LAMBDA (SLOT) (IF (CONSP SLOT) (CADR SLOT)))
|
||||
SLOTSPECS) )
|
||||
|
||||
|
||||
(DEFUN CHECK-INCLUDED-STRUCT (NAME ISTRUCT NAMED?)
|
||||
; Checks that the (:INCLUDE ...) option ISTRUCT (if any) specifies a
|
||||
; valid, previously defined structure which is compatible with the
|
||||
; structure being defined.
|
||||
((NULL ISTRUCT) NIL)
|
||||
(LET ((iname (CADR ISTRUCT)) )
|
||||
((GET iname 'STRUCT-MACROS)
|
||||
((GET iname 'NAMED-STRUCT)
|
||||
((IDENTITY NAMED?) T)
|
||||
(BREAK (LIST* 'DEFSTRUCT STRUCTSPEC SLOTSPECS)
|
||||
"Include Error") )
|
||||
((NOT NAMED?) T)
|
||||
(BREAK (LIST* 'DEFSTRUCT STRUCTSPEC SLOTSPECS)
|
||||
"Include Error") )
|
||||
(BREAK (LIST* 'DEFSTRUCT STRUCTSPEC SLOTSPECS)
|
||||
"Undefined Structure") ) )
|
||||
|
||||
(DEFUN CHECK-STRUCT-MACDEFS (NAME MACDEFS)
|
||||
; Checks that each MACRO (<name> . <definition>) pair in the list
|
||||
; MACDEFS will NOT cause an incompatible redefinition of an existing
|
||||
; function.
|
||||
(MAPCAR '(LAMBDA (MACDEF)
|
||||
((OR (NULL (GETD (CAR MACDEF) T))
|
||||
(EQUAL (GETD (CAR MACDEF)) (CDR MACDEF)) )
|
||||
MACDEF)
|
||||
(IF (NULL (GET (CAR MACDEF) 'STRUCTS))
|
||||
(PUT (CAR MACDEF) 'STRUCTS (CONS)) )
|
||||
((NULL (REMOVE NAME (GET (CAR MACDEF) 'STRUCTS)))
|
||||
MACDEF)
|
||||
(BREAK (LIST* 'DEFSTRUCT STRUCTSPEC SLOTSPECS)
|
||||
"Incompatible Definition") )
|
||||
MACDEFS) )
|
||||
|
||||
|
||||
(DEFUN FORM-STRUCT-CONSTRUCTORS (NAME OPTIONS SLOTNAMS SLOTVALS NAMED?)
|
||||
; Formulates constructor functions as MACROs for the structure NAME in
|
||||
; accordance with OPTIONS, SLOTNAMS, SLOTVALS, and NAMED?. Returns a
|
||||
; list of constructor function (<name> . <definition>) pairs (or NIL
|
||||
; if no constructor functions were desired).
|
||||
(LET ((consopt (ASSOC ':CONSTRUCTOR OPTIONS)) )
|
||||
((NULL consopt)
|
||||
(LIST (CONS (PACK* 'MAKE- NAME)
|
||||
(STRUCT-KEYWORD-CONSTRUCTOR NAME SLOTNAMS SLOTVALS
|
||||
NAMED?))) )
|
||||
(MAPCAN '(LAMBDA (OPT)
|
||||
((EQ (CAR OPT) ':CONSTRUCTOR)
|
||||
((NULL (CDR OPT))
|
||||
(LIST (CONS (PACK* 'MAKE- NAME)
|
||||
(STRUCT-KEYWORD-CONSTRUCTOR NAME
|
||||
SLOTNAMS SLOTVALS NAMED?))) )
|
||||
((NULL (CADR OPT)) )
|
||||
((NULL (CDDR OPT))
|
||||
(LIST (CONS (CADR OPT)
|
||||
(STRUCT-KEYWORD-CONSTRUCTOR NAME
|
||||
SLOTNAMS SLOTVALS NAMED?))) )
|
||||
(LIST (CONS (CADR OPT)
|
||||
(STRUCT-POSITIONAL-CONSTRUCTOR NAME
|
||||
SLOTNAMS SLOTVALS (CADDR OPT)
|
||||
NAMED?))) ) )
|
||||
OPTIONS) ) )
|
||||
|
||||
(DEFUN STRUCT-KEYWORD-CONSTRUCTOR (NAME SLOTNAMS SLOTVALS NAMED?)
|
||||
; Formulates a keyword constructor function as a MACRO for the structure
|
||||
; NAME in accordance with SLOTNAMS, SLOTVALS, and NAMED?. Returns the
|
||||
; definition for the constructor.
|
||||
(LIST 'MACRO
|
||||
'SLOTSPECS
|
||||
(APPEND '(LIST* 'LIST)
|
||||
(IF NAMED? (LIST (LIST 'QUOTE (LIST 'QUOTE NAME))))
|
||||
(LIST (LIST 'MAPCAR
|
||||
''(LAMBDA (SNAM SVAL)
|
||||
(LET ((spec (MEMBER (PACK* '":" SNAM)
|
||||
SLOTSPECS)) )
|
||||
((NULL spec) SVAL)
|
||||
(CADR spec) ) )
|
||||
(LIST 'QUOTE SLOTNAMS)
|
||||
(LIST 'QUOTE SLOTVALS) ) ) ) ) )
|
||||
|
||||
(DEFUN STRUCT-POSITIONAL-CONSTRUCTOR (NAME SLOTNAMS SLOTVALS ARGS NAMED?)
|
||||
; Formulates a positional constructor as a MACRO for the structure NAME
|
||||
; in accordance with SLOTNAMS, SLOTVALS, ARGS, and NAMED?. Returns the
|
||||
; definition for the constructor.
|
||||
(LIST 'MACRO
|
||||
'BODY
|
||||
(APPEND '(LIST 'LIST)
|
||||
(IF NAMED? (LIST (LIST 'QUOTE (LIST 'QUOTE NAME))))
|
||||
(MAPCAR '(LAMBDA (SNAM SVAL)
|
||||
((MEMBER SNAM ARGS)
|
||||
(LIST 'NTH
|
||||
(ADD1 (POSITION SNAM ARGS))
|
||||
'BODY) )
|
||||
SVAL)
|
||||
SLOTNAMS
|
||||
SLOTVALS) ) ) )
|
||||
|
||||
(DEFUN FORM-STRUCT-ACCESSORS (NAME OPTIONS SLOTNAMS NAMED?)
|
||||
; Formulates accessor functions as MACROs for the structure NAME in
|
||||
; accordance with OPTIONS, SLOTNAMS, and NAMED?. Returns a list of
|
||||
; accessor function (<name> . <definition>) pairs.
|
||||
(LET ((namopt (ASSOC ':CONC-NAME OPTIONS)) )
|
||||
(LET ((prefix (COND ((OR (NULL namopt)
|
||||
(NULL (CDR namopt)) )
|
||||
(PACK* NAME '"-") )
|
||||
((NULL (CADR namopt)) '"")
|
||||
((CADR namopt)) ) )
|
||||
(slotpsn (IF NAMED? 1 0)) )
|
||||
(MAPCAR '(LAMBDA (SNAM)
|
||||
(CONS (PACK* prefix SNAM)
|
||||
(LIST 'MACRO 'BODY
|
||||
(LIST 'LIST ''NTH slotpsn (LIST 'CADR 'BODY)))
|
||||
(INCQ slotpsn)) )
|
||||
SLOTNAMS) ) ) )
|
||||
|
||||
(DEFUN FORM-STRUCT-PREDICATE (NAME OPTIONS NAMED?)
|
||||
; Formulates a predicate function as a MACRO for the structure NAME in
|
||||
; accordance with OPTIONS and NAMED?. Returns a list consisting of the
|
||||
; predicate function (<name> . <definition>) pair (or NIL if no predicate
|
||||
; function was desired).
|
||||
(LET ((predopt (ASSOC ':PREDICATE OPTIONS)) )
|
||||
((NOT NAMED?)
|
||||
((OR (NULL predopt)
|
||||
(AND (CDR predopt)
|
||||
(NULL (CADR predopt)) ) ) )
|
||||
(BREAK (LIST* 'DEFSTRUCT STRUCTSPEC SLOTSPECS)
|
||||
"Unnamed Structure") )
|
||||
((OR (NULL predopt)
|
||||
(NULL (CDR predopt))
|
||||
(CADR predopt))
|
||||
(LIST (CONS (IF (OR (NULL predopt) (NULL (CDR predopt)))
|
||||
(PACK* NAME '"-P")
|
||||
(CADR predopt) )
|
||||
(LIST 'MACRO
|
||||
'BODY
|
||||
(LIST 'LIST
|
||||
''EQ
|
||||
(LIST 'LIST
|
||||
''CAR
|
||||
(LIST 'CADR 'BODY))
|
||||
(LIST 'QUOTE (LIST 'QUOTE NAME)))) ) ) ) ) )
|
||||
|
||||
(DEFUN FORM-STRUCT-COPIER (NAME OPTIONS)
|
||||
; Formulates a copier function as a MACRO for the structure NAME in
|
||||
; accordance with OPTIONS. Returns a list consisting of the copier
|
||||
; function (<name> . <definition>) pair (or NIL if no copier function
|
||||
; was desired).
|
||||
(LET ((copyopt (ASSOC ':COPIER OPTIONS)) )
|
||||
((OR (NULL copyopt)
|
||||
(NULL (CDR copyopt))
|
||||
(CADR copyopt))
|
||||
(LIST (CONS (IF (OR (NULL copyopt) (NULL (CDR copyopt)))
|
||||
(PACK* 'COPY- NAME)
|
||||
(CADR copyopt) )
|
||||
(LIST 'MACRO
|
||||
'BODY
|
||||
(LIST 'LIST
|
||||
''COPY-LIST
|
||||
(LIST 'CADR 'BODY)) ) ) ) ) ) )
|
||||
|
||||
|
||||
(DEFUN PUTSTRUCT (NAME OPTIONS SLOTNAMS SLOTVALS NAMED? MACDEFS)
|
||||
; Installs the structure NAME.
|
||||
(IF (GET NAME 'STRUCT-MACROS) (REMSTRUCT NAME) )
|
||||
(PUT NAME 'STRUCT-OPTIONS OPTIONS)
|
||||
(PUT NAME 'STRUCT-SLOTNAMES SLOTNAMS)
|
||||
(PUT NAME 'STRUCT-SLOTVALS SLOTVALS)
|
||||
(PUT NAME 'NAMED-STRUCT NAMED?)
|
||||
(PUT NAME 'STRUCT-MACROS
|
||||
(MAPCAR '(LAMBDA (MACDEF)
|
||||
(PUT (CAR MACDEF) 'STRUCTS
|
||||
(CONS NAME (GET (CAR MACDEF) 'STRUCTS)))
|
||||
(PUTD (CAR MACDEF) (CDR MACDEF)) )
|
||||
MACDEFS))
|
||||
NAME )
|
||||
|
||||
(DEFUN REMSTRUCT (NAME)
|
||||
; Removes the structure NAME.
|
||||
(REMPROP NAME 'STRUCT-OPTIONS)
|
||||
(REMPROP NAME 'STRUCT-SLOTNAMES)
|
||||
(REMPROP NAME 'STRUCT-SLOTVALS)
|
||||
(REMPROP NAME 'NAMED-STRUCT)
|
||||
(MAPC '(LAMBDA (MACDEF)
|
||||
(LET ((sts (REMOVE NAME (GET MACDEF 'STRUCTS))) )
|
||||
((NULL sts)
|
||||
(REMPROP MACDEF 'STRUCTS)
|
||||
(REMD MACDEF) )
|
||||
(PUT MACDEF 'STRUCTS sts) ) )
|
||||
(GET NAME 'STRUCT-MACROS) )
|
||||
(REMPROP NAME 'STRUCT-MACROS) )
|
||||
|
||||
(RDS)
|
||||
|
||||
212
Microsoft muLISP-86 v51/TTT.LSP
Normal file
212
Microsoft muLISP-86 v51/TTT.LSP
Normal file
@ -0,0 +1,212 @@
|
||||
; Prove you can't win at tic-tac-toe if the opponent is competent.
|
||||
; written for Microsoft Lisp v5 (muLISP-86)
|
||||
; requires common.lsp and structur.lsp to have been loaded
|
||||
|
||||
(setq score-win 6)
|
||||
(setq score-tie 5)
|
||||
(setq score-lose 4)
|
||||
(setq score-max 9)
|
||||
(setq score-min 2)
|
||||
(setq piece-blank 0)
|
||||
(setq piece-x 1)
|
||||
(setq piece-o 2)
|
||||
(setq moves 0)
|
||||
(setq board (make-array 9 :initial-element 0 ))
|
||||
(setq winpiece piece-blank)
|
||||
|
||||
(defun iswin (x y z)
|
||||
(setq winpiece (cxr x board))
|
||||
(cond ((and (not (= winpiece piece-blank)) (= winpiece (cxr y board)) (= winpiece (cxr z board)))))
|
||||
)
|
||||
|
||||
(defun winner()
|
||||
(cond ((or (iswin 0 1 2)
|
||||
(iswin 0 3 6)
|
||||
(iswin 1 4 7)
|
||||
(iswin 2 5 8)
|
||||
(iswin 3 4 5)
|
||||
(iswin 4 0 8)
|
||||
(iswin 4 2 6)
|
||||
(iswin 6 7 8))
|
||||
winpiece)
|
||||
(t piece-blank)
|
||||
)
|
||||
)
|
||||
|
||||
(defun proc0(x)
|
||||
(cond ((or (and (= x (aref board 1)) (= x (aref board 2)))
|
||||
(and (= x (aref board 3)) (= x (aref board 6)))
|
||||
(and (= x (aref board 4)) (= x (aref board 8))))
|
||||
x) (t piece-blank))
|
||||
)
|
||||
|
||||
(defun proc1(x)
|
||||
(cond ((or (and (= x (aref board 0)) (= x (aref board 2)))
|
||||
(and (= x (aref board 4)) (= x (aref board 7))))
|
||||
x) (t piece-blank))
|
||||
)
|
||||
|
||||
(defun proc2(x)
|
||||
(cond ((or (and (= x (aref board 0)) (= x (aref board 1)))
|
||||
(and (= x (aref board 5)) (= x (aref board 8)))
|
||||
(and (= x (aref board 4)) (= x (aref board 6))))
|
||||
x) (t piece-blank))
|
||||
)
|
||||
|
||||
(defun proc3(x)
|
||||
(cond ((or (and (= x (aref board 4)) (= x (aref board 5)))
|
||||
(and (= x (aref board 0)) (= x (aref board 6))))
|
||||
x) (t piece-blank))
|
||||
)
|
||||
|
||||
(defun proc4(x)
|
||||
(cond ((or (and (= x (aref board 0)) (= x (aref board 8)))
|
||||
(and (= x (aref board 2)) (= x (aref board 6)))
|
||||
(and (= x (aref board 1)) (= x (aref board 7)))
|
||||
(and (= x (aref board 3)) (= x (aref board 5))))
|
||||
x) (t piece-blank))
|
||||
)
|
||||
|
||||
(defun proc5(x)
|
||||
(cond ((or (and (= x (aref board 3)) (= x (aref board 4)))
|
||||
(and (= x (aref board 2)) (= x (aref board 8))))
|
||||
x) (t piece-blank))
|
||||
)
|
||||
|
||||
(defun proc6(x)
|
||||
(cond ((or (and (= x (aref board 7)) (= x (aref board 8)))
|
||||
(and (= x (aref board 0)) (= x (aref board 3)))
|
||||
(and (= x (aref board 2)) (= x (aref board 4))))
|
||||
x) (t piece-blank))
|
||||
)
|
||||
|
||||
(defun proc7(x)
|
||||
(cond ((or (and (= x (aref board 6)) (= x (aref board 8)))
|
||||
(and (= x (aref board 1)) (= x (aref board 4))))
|
||||
x) (t piece-blank))
|
||||
)
|
||||
|
||||
(defun proc8(x)
|
||||
(cond ((or (and (= x (aref board 6)) (= x (aref board 7)))
|
||||
(and (= x (aref board 2)) (= x (aref board 5)))
|
||||
(and (= x (aref board 0)) (= x (aref board 4))))
|
||||
x) (t piece-blank))
|
||||
)
|
||||
|
||||
(defun mmMax (alpha beta depth move) (prog (i value nextDepth) ; this is how local variables are declared
|
||||
(setq moves (+ 1 moves))
|
||||
;(princ "max: ") (princ board) (princ " ") (princ alpha) (princ " ") (princ beta) (princ " ") (princ move) (princ " ") (princ depth) (princ "\n")
|
||||
|
||||
(cond ((> depth 3)
|
||||
;(setq win (winner)) ; almost 2x slower than using procs
|
||||
;(setq win (funcall (concat 'proc move) piece-o)) ; slower than using the procs hunk
|
||||
(setq win (funcall (aref procs move) piece-o))
|
||||
(cond ((= win piece-o) (return score-lose))))
|
||||
)
|
||||
|
||||
(setq value score-min)
|
||||
(setq nextDepth (+ 1 depth))
|
||||
(setq i 0)
|
||||
_nexti_
|
||||
(cond ((= (aref board i) piece-blank)
|
||||
(setf (aref board i) piece-x)
|
||||
(setq score (mmMin alpha beta nextDepth i))
|
||||
(setf (aref board i) piece-blank)
|
||||
|
||||
(cond ((= score score-win)
|
||||
(return score-win))
|
||||
((> score value)
|
||||
(setq value score)
|
||||
(cond ((>= value beta)
|
||||
(return value))
|
||||
((> value alpha)
|
||||
(setq alpha value))))
|
||||
))
|
||||
)
|
||||
|
||||
(cond ((< i 8)
|
||||
(setq i (+ i 1))
|
||||
(go _nexti_))
|
||||
)
|
||||
|
||||
(return value)
|
||||
))
|
||||
|
||||
(defun mmMin (alpha beta depth move) (prog (i value nextDepth) ; this is how local variables are declared
|
||||
(setq moves (+ 1 moves))
|
||||
;(princ "min: ") (princ board) (princ " ") (princ alpha) (princ " ") (princ beta) (princ " ") (princ move) (princ " ") (princ depth) (princ "\n")
|
||||
|
||||
(cond ((> depth 3)
|
||||
;(setq win (winner)) ; almost 2x slower than using procs
|
||||
;(setq win (funcall (concat 'proc move) piece-x)) ; slower than using the procs hunk
|
||||
(setq win (funcall (aref procs move) piece-x))
|
||||
(cond ((= win piece-x) (return score-win))
|
||||
((= depth 8) (return score-tie))
|
||||
))
|
||||
)
|
||||
|
||||
(setq value score-max)
|
||||
(setq nextDepth (+ 1 depth))
|
||||
(setq i 0)
|
||||
_nexti_
|
||||
(cond ((= (aref board i) piece-blank)
|
||||
(setf (aref board i) piece-o)
|
||||
(setq score (mmMax alpha beta nextDepth i))
|
||||
(setf (aref board i) piece-blank)
|
||||
|
||||
(cond ((= score score-lose)
|
||||
(return score-lose))
|
||||
((< score value)
|
||||
(setq value score)
|
||||
(cond ((<= value alpha)
|
||||
(return value))
|
||||
((< value beta)
|
||||
(setq beta value))))
|
||||
))
|
||||
)
|
||||
|
||||
(cond ((< i 8)
|
||||
(setq i (+ i 1))
|
||||
(go _nexti_))
|
||||
)
|
||||
|
||||
(return value)
|
||||
))
|
||||
|
||||
(defun runmm (position)
|
||||
(setf (aref board position) piece-x)
|
||||
(mmMin score-min score-max 0 position)
|
||||
(setf (aref board position) piece-blank)
|
||||
(return "")
|
||||
)
|
||||
|
||||
(setq procs (make-array 9))
|
||||
(setf (aref procs 0) proc0)
|
||||
(setf (aref procs 1) proc1)
|
||||
(setf (aref procs 2) proc2)
|
||||
(setf (aref procs 3) proc3)
|
||||
(setf (aref procs 4) proc4)
|
||||
(setf (aref procs 5) proc5)
|
||||
(setf (aref procs 6) proc6)
|
||||
(setf (aref procs 7) proc7)
|
||||
(setf (aref procs 8) proc8)
|
||||
|
||||
(defun runall ()
|
||||
(runmm 0)
|
||||
(runmm 1)
|
||||
(runmm 4)
|
||||
)
|
||||
|
||||
(clear-screen)
|
||||
(setq startTime (time))
|
||||
(dotimes (z 10) (runall))
|
||||
|
||||
(write-string "moves: ") (princ moves) ; should be 6493
|
||||
(princ "elapsed hundredths of a second: ") (- (time) startTime) (TERPRI)
|
||||
|
||||
;(princ "memstat: ") (princ (memstat)) (princ "\n")
|
||||
;(gc)
|
||||
;(princ "memstat post gc: ") (princ (memstat)) (princ "\n")
|
||||
|
||||
(system)
|
||||
|
||||
5
Microsoft muLISP-86 v51/m.bat
Normal file
5
Microsoft muLISP-86 v51/m.bat
Normal file
@ -0,0 +1,5 @@
|
||||
copy common.lsp+structur.lsp+%1.lsp foo.lsp
|
||||
REM first remove (rds) twice from foo.lsp
|
||||
type foo.lsp | findstr /i /B /V (RDS) >bar.lsp
|
||||
ntvdm -p -c mulisp bar.lsp
|
||||
|
||||
Loading…
Reference in New Issue
Block a user