home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #1
/
monster.zip
/
monster
/
PROG_PAS
/
APTERYX.ZIP
/
GEN.LSP
< prev
next >
Wrap
Lisp/Scheme
|
1994-01-28
|
3KB
|
121 lines
; general lisp functions
; Copyright 1994 Apteryx Lisp Ltd
(setq *is-apteryx* (boundp '*apteryx-if-bound*))
(defun get-no-fail (sym prop)
(let ( (value (get sym prop)) )
(if (not value)
(error "Failure to retrieve property" (list sym prop)) )
value) )
(defmacro pr (name)
`(progn
(format t "~S = ~S~%" ',name ,name)
,name) )
(defmacro push (list el)
`(setq ,list (cons ,el ,list)) )
(defmacro pop (list)
`(setq ,list (cdr ,list)) )
(defun flatten (list)
(let ( (out nil) )
(dolist (elt list)
(if (listp elt)
(setq out (append (reverse (flatten elt)) out))
(setq out (cons elt out)) ) )
(reverse out) ) )
; (flatten '(a ((b c)) (d e) (f (g h)) (i) () j k))
(defun quoted (x)
(list 'quote x))
(defconstant decimal-digits (vector "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
(defun ordinal (n)
(strcat (prin1-to-string n)
(let ( (n100 (rem n 100)) )
(if (and (> n100 10) (< n100 20))
"th"
(case (rem n 10)
(1 "st")
(2 "nd")
(3 "rd")
(t "th") ) ) ) ) )
;(ordinal 31)
(defmacro with-open-file (name stream direc &rest exprs)
`(let ((,stream (open ,name :direction ,direc)))
(if ,stream
(unwind-protect
(progn ,@exprs)
(close ,stream) )
(error "Failure to open file" name) ) ) )
(defun print-spaces (n)
(dotimes (i n) (princ " ")) )
(defun and-fun (&rest args)
(eval (cons 'and args)) )
(defmacro addf (place increment)
`(setf ,place (+ ,place ,increment)) )
(defmacro subf (place increment)
`(setf ,place (- ,place ,increment)) )
(defun lines-of-file (filename)
(let ( (list nil) )
(with-open-file filename file :input
(while (not (eofp file))
(let ( (line (read-line file)) )
(if (stringp line)
(setq list (cons line list)) ) ) ) )
(reverse list) ) )
;;; sorting
(defun split-list (list)
(let ( (list1 nil) (list2 nil) (list3 nil))
(dolist (elt (reverse list))
(setq list3 (cons elt list1))
(setq list1 list2)
(setq list2 list3) )
(cons list2 list1) ) )
; (split-list '(1 2 3 4 5 6 7 8))
(defun merged (list1 list2 less-than)
(let ( (result nil) (rem-list1 list1) (rem-list2 list2) next-elt)
(while (or rem-list1 rem-list2)
(if (or (null rem-list2)
(and rem-list1
(funcall less-than (car rem-list1) (car rem-list2)) ) )
(progn
(setq next-elt (car rem-list1))
(setq rem-list1 (cdr rem-list1)) )
(progn
(setq next-elt (car rem-list2))
(setq rem-list2 (cdr rem-list2)) ) )
(setq result (cons next-elt result)) )
(reverse result) ) )
(merged '(1 3 5) '(2 6 8) #'<)
(defun merge-sort (list less-than)
(if (<= (length list) 1)
list
(let* ( (halves (split-list list))
(list1-sorted (merge-sort (car halves) less-than))
(list2-sorted (merge-sort (cdr halves) less-than)) )
(merged list1-sorted list2-sorted less-than) ) ) )
(defun sort (list less-than)
(merge-sort list less-than) )
; (sort '(5 7 1 5 10 20 300 -5 71 3 8 9) #'<)