home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / aptery10 / gen.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-01-28  |  3.2 KB  |  121 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.