ulisp/tdeck/library.lsp

(defvar *cmds* nil)
(defvar *picn* 0)

(defun every (tst lst)
  "(every tst lst)
Returns t if tst is true for every item in lst, or nil on the first false item."
  (if (null lst) t
    (and (funcall tst (car lst)) (every tst (cdr lst)))))

(defun load (filename)
 "(load filename)
Open the Lisp file on the SD card and load the contents into the workspace."
  (with-sd-card (str filename)
    (let ((forms nil))
      (loop
	(let ((form  (read str)))
	  (unless form (return))
	  (setf forms (cons (cadr form) forms))
	  (eval form)))
      (reverse forms))))

(defun load-package (filename )
  (let* ((filename (concatenate 'string filename ".pkg"))
         (forms    (load filename)))
    forms))

(defun save-package (filename lst)
  (with-sd-card (str filename 2)
   (dolist (f lst)
      (symbol-def f str))))

(defun add-to-package (filename list)
   (with-sd-card (str filename 1)
     (dolist (f lst)
         (symbol-def f str))))

(defun rgb (r g b)
  "(rgb r g b)
Define a colour from its RGB components."
  (logior (ash (logand r #xf8) 8) (ash (logand g #xfc) 3) (ash b -3)))

(defun hsv (h s v)
  "(hsv h s v)
Specify colours in the alternative HSV colour system."
  (let* ((chroma (* v s))
         (x (* chroma (- 1 (abs (- (mod (/ h 60) 2) 1)))))
         (m (- v chroma))
         (i (truncate h 60))
         (params (list chroma x 0 0 x chroma))
         (r (+ m (nth i params)))
         (g (+ m (nth (mod (+ i 4) 6) params)))
         (b (+ m (nth (mod (+ i 2) 6) params))))
    (rgb (round (* r 255)) (round (* g 255)) (round (* b 255)))))

(defun col (n)
  "(col n)
Defines a different colour for each value of n from 0 to 7."
  (rgb (* (logand n 1) 160) (* (logand n 2) 80) (* (logand n 4) 40)))

(defun butlast (lst)
  "(butlast lst)
Returns all but the last item in lst."
  (unless (null lst) (subseq lst 0 (1- (length lst)))))

(defun count (x lst)
  "(count x lst)
Counts the number of items eq to x in lst."
  (if (null lst) 0
    (+ (if (eq x (car lst)) 1 0) (count x (cdr lst)))))

(defun count-if (tst lst)
  "(count-if tst lst)
Counts the number of items in lst for which tst is true."
  (if (null lst) 0
    (+ (if (funcall tst (car lst)) 1 0) (count-if tst (cdr lst)))))

(defun count-if-not (tst lst)
  "(count-if-not tst lst)
Counts the number of items in lst for which tst is false."
  (if (null lst) 0
    (+ (if (funcall tst (car lst)) 0 1) (count-if-not tst (cdr lst)))))

(defun find (x lst)
  "(find x lst)
Returns x if x is in lst, or nil otherwise."
  (car (member x lst)))

(defun find-if (tst lst)
  "(find-if tst lst)
Returns the first item in lst for which tst is true, or nil otherwise."
  (cond
   ((null lst) nil)
   ((funcall tst (car lst)) (car lst))
   (t (find-if tst (cdr lst)))))

(defun find-if-not (tst lst)
  "(find-if-not tst lst)
Returns the first item in lst for which tst is false, or nil otherwise."
  (cond
   ((null lst) nil)
   ((not (funcall tst (car lst))) (car lst))
   (t (find-if-not tst (cdr lst)))))

(defun identity (x)
  "(identity x)
Returns its argument."
  x)

(defun last (lst)
  "(last lst)
Returns the last cdr of lst."
  (unless (null lst) (subseq lst (1- (length lst)))))

(defun mapl (fn lst)
  "(mapl fn lst)
Applies fn to successive cdrs of lst, and returns lst."
  (mapl2 fn lst)
  lst)

(defun mapl2 (fn lst)
  (cond
   ((null lst) nil)
   (t (funcall fn lst)
      (mapl2 fn (cdr lst)))))

(defun maplist (fn lst)
  "(maplist fn lst)
Applies fn to successive cdrs of lst, and returns a list of the results."
  (if (null lst) nil
   (cons (funcall fn lst) (maplist fn (cdr lst)))))

(defun nconc (&rest lst)
  "(nconc lst*)
Destructively appends its arguments together, which must be lists."
  (mapcan #'(lambda (x) x) lst))

(defun nthcdr (n lst)
  "(nthcdr n lst)
Returns the nth cdr of lst."
  (if (zerop n) lst
    (nthcdr (1- n) (cdr lst))))

(defun position (x lst &optional (n 0))
  "(position x lst)
Returns the position of the first x in lst, or nil if it's not found."
  (cond
   ((null lst) nil)
   ((eq x (car lst)) n)
   (t (position x (cdr lst) (1+ n)))))

(defun position-if (tst lst &optional (n 0))
  "(position-if tst lst)
Returns the position of the first item in lst for which tst is true,
or nil if none is found."
  (cond
   ((null lst) nil)
   ((funcall tst (car lst)) n)
   (t (position-if tst (cdr lst) (1+ n)))))

(defun position-if-not (tst lst &optional (n 0))
  "(position-if-not tst lst)
Returns the position of the first item in lst for which tst is false,
or nil if none is found."
  (cond
   ((null lst) nil)
   ((not (funcall tst (car lst))) n)
   (t (position-if-not tst (cdr lst) (1+ n)))))

(defun reduce (fn lst)
  "(reduce fn lst)
Returns the result of applying fn to successive pairs of items from lst."
     (if (null (cdr lst)) (car lst)
      (funcall fn (car lst) (reduce fn (cdr lst)))))

(defun remove (x lst)
  "(remove x lst)
Returns a list with all occurrences of x removed from lst."
  (mapcan #'(lambda (y) (unless (eq x y) (list y))) lst))

(defun remove-if (tst lst)
  "(remove-if tst lst)
Returns a list with all items for which tst is true removed from lst."
  (mapcan #'(lambda (x) (unless (funcall tst x) (list x))) lst))

(defun remove-if-not (tst lst)
  "(remove-if-not tst lst)
Returns a list with all items for which tst is false removed from lst."
  (mapcan #'(lambda (x) (when (funcall tst x) (list x))) lst))


(defun append-to-list (itm lst)
  "(append-to-list itm lst)
Appends item to list destructively; lst will be altered with
itm appended to the end of the list."
  (if lst (nconc lst (list itm))
      (setf lst (list itm))))

(defun user-symbols ()
  "(user-symbols)
Returns a list of all the symbols add by a user after boot."
  (let ((library (list-library2)))
   (remove-if (lambda (sym) (member sym library)) (globals))))

(defun reset-user-environment ()
  "(reset-user-environment)
Removes all user-defined symbols."
  (mapcar 'makunbound (user-symbols)))

(defun keyword-string (k)
  "(keyword-string k)
Returns the keyword as a string, or nil if the arg isn't a keyword."
  (when (keywordp k)
   (subseq (string k) 1)))

(defun load-platform ()
 "(load-platform)
Load-platform specific code if present, found on the SD card as
platform.lsp (e.g. picocalc.lsp)."
 (let ((platform-file (concatenate 'string (keyword-string (platform)) ".lsp")))
  (when (sd-exists-p platform-file)
   (load platform-file))))

(load-platform)

(defvar *pkg* nil)

(defun lp ()
  (setf *pkg* (load "pkg.lsp")))