home *** CD-ROM | disk | FTP | other *** search
/ CD Direkt 1995 #1 / Image.iso / cdd / winanw / aperyx / gen.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-02-05  |  4.6 KB  |  164 lines
  1. ; general lisp functions 
  2. ; Copyright 1994 Apteryx Lisp Ltd
  3.  
  4. (setq *is-apteryx* (boundp '*apteryx-if-bound*))
  5.  
  6. (defun get-no-fail (sym prop)
  7.   (let ( (value (get sym prop)) )
  8.     (if (not value)
  9.       (error "Failure to retrieve property" (list sym prop)) )
  10.     value) )
  11.  
  12. (defmacro pr (name)
  13.   `(progn
  14.      (format t "~S = ~S~%" ',name ,name)
  15.      ,name) )
  16.  
  17. (defmacro push (list el)
  18.   `(setq ,list (cons ,el ,list)) )
  19.  
  20. (defmacro pop (list)
  21.   `(setq ,list (cdr ,list)) )
  22.  
  23. (defun flatten (list)
  24.   (let ( (out nil) )
  25.     (dolist (elt list)
  26.       (if (listp elt)
  27.         (setq out (append (reverse (flatten elt)) out))
  28.         (setq out (cons elt out)) ) )
  29.     (reverse out) ) )
  30.  
  31. ; (flatten '(a ((b c)) (d e) (f (g h)) (i) () j k))
  32.  
  33. (defun quoted (x)
  34.   (list 'quote x))
  35.  
  36. (defconstant decimal-digits (vector "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
  37.  
  38. (defun ordinal (n)
  39.   (strcat (prin1-to-string n)
  40.     (let ( (n100 (rem n 100)) )
  41.       (if (and (> n100 10) (< n100 20))
  42.         "th"
  43.         (case (rem n 10)
  44.           (1 "st")
  45.           (2 "nd")
  46.           (3 "rd")
  47.           (t "th") ) ) ) ) )
  48. ;(ordinal 31)
  49.  
  50. (defmacro with-open-file (name stream direc &rest exprs)
  51.   `(let ((,stream (open ,name :direction ,direc)))
  52.      (if ,stream
  53.        (unwind-protect
  54.          (progn ,@exprs)
  55.          (close ,stream) )
  56.        (error "Failure to open file" name) ) ) )
  57.  
  58. (defun print-spaces (n)
  59.   (dotimes (i n) (princ " ")) )
  60.  
  61. (defun and-fun (&rest args)
  62.   (eval (cons 'and args)) )
  63.  
  64. (defmacro addf (place increment)
  65.   `(setf ,place (+ ,place ,increment)) )
  66.  
  67. (defmacro subf (place increment)
  68.   `(setf ,place (- ,place ,increment)) )
  69.  
  70. (defun lines-of-file (filename)
  71.   (let ( (list nil) )
  72.     (with-open-file filename file :input
  73.       (while (not (eofp file))
  74.         (let ( (line (read-line file)) )
  75.           (if (stringp line)
  76.             (setq list (cons line list)) ) ) ) )
  77.     (reverse list) ) )
  78.  
  79. ;;; sorting
  80.  
  81. (defun split-list (list)
  82.   (let ( (list1 nil) (list2 nil) (list3 nil))
  83.     (dolist (elt (reverse list))
  84.       (setq list3 (cons elt list1))
  85.       (setq list1 list2)
  86.       (setq list2 list3) )
  87.     (cons list2 list1) ) )
  88.  
  89. ; (split-list '(1 2 3 4 5 6 7 8))
  90.  
  91. (defun merged (list1 list2 less-than)
  92.   (let ( (result nil) (rem-list1 list1) (rem-list2 list2) next-elt)
  93.     (while (or rem-list1 rem-list2)
  94.       (if (or (null rem-list2)
  95.             (and rem-list1
  96.               (funcall less-than (car rem-list1) (car rem-list2)) ) )
  97.         (progn
  98.           (setq next-elt (car rem-list1))
  99.           (setq rem-list1 (cdr rem-list1)) )
  100.         (progn
  101.           (setq next-elt (car rem-list2))
  102.           (setq rem-list2 (cdr rem-list2)) ) )
  103.       (setq result (cons next-elt result)) )
  104.     (reverse result) ) )
  105.  
  106. (merged '(1 3 5) '(2 6 8) #'<)
  107.  
  108. (defun merge-sort (list less-than)
  109.   (if (<= (length list) 1)
  110.     list
  111.     (let* ( (halves (split-list list))
  112.             (list1-sorted (merge-sort (car halves) less-than))
  113.             (list2-sorted (merge-sort (cdr halves) less-than)) )
  114.       (merged list1-sorted list2-sorted less-than) ) ) )
  115.  
  116. (defun sort (list less-than)
  117.   (merge-sort list less-than) )
  118.       
  119. ; (sort '(5 7 1 5 10 20 300 -5 71 3 8 9) #'<)
  120.  
  121. ; fake progv - main difference is that there is no
  122. ; distinction between dynamic and global value.
  123.  
  124. (defmacro progv (symbols values &rest stmts)
  125.   (let ( (unbound-value (gensym))
  126.          (symbols2 (gensym))
  127.          (rest-values (gensym))
  128.          (old-value (gensym))
  129.          (old-values (gensym)) )
  130.     `(let* ( (,unbound-value (gensym))
  131.              (,symbols2 ,symbols)
  132.              (,rest-values ,values)
  133.              ,old-value
  134.              (,old-values (mapcar #'(lambda (sym)
  135.                                       (if (boundp sym)
  136.                                         (symbol-value sym)
  137.                                         ,unbound-value) )
  138.                             ,symbols2) ) )
  139.        (unwind-protect
  140.          (progn
  141.            (dolist (sym ,symbols2)
  142.              (if ,rest-values
  143.                (progn
  144.                  (set sym (car ,rest-values))
  145.                  (setq ,rest-values  (cdr ,rest-values)) )
  146.                (makunbound sym) ) )
  147.            ,@stmts)
  148.          (dolist (sym ,symbols2)
  149.            (setq ,old-value (car ,old-values))
  150.            (setq ,old-values (cdr ,old-values))
  151.            (if (eq ,old-value ,unbound-value)
  152.              (makunbound sym)
  153.              (set sym ,old-value) ) ) ) ) ) )
  154.  
  155. ;(defun show-a () (format t "a = ~A~%" a))
  156. ;(defun show-b () (format t "b = ~A~%" b))
  157. ;(setq a 10) (setq b 11)
  158. ;(let ( (a 32) )
  159. ;  (progv '(a b) '(39 34)
  160. ;    (show-a) (show-b) )
  161. ;  )
  162. ;(show-a)
  163.  
  164.