// Library of additional Lisp functions with integral documentation
// LispLibrary.h - Version 2 - 5th November 2023

const char LispLibrary[] PROGMEM = R"lisplibrary(
(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")))

(when (eq (platform) :t-deck)
(defun %edit (fun)
  (cond
   ((null *cmds*) fun)
   ((eq (car *cmds*) #\b) (pop *cmds*) fun)
   ((eq (car *cmds*) #\e) (pop *cmds*) (%edit (list fun)))
   ((eq (car *cmds*) #\h) (pop *cmds*) (%edit (cons 'highlight (list fun))))
   ((consp (car *cmds*))
    (let ((val (cdar *cmds*)))
      (case (caar *cmds*)
        (#\r (pop *cmds*) (%edit val))
        ((#\c #\i) (pop *cmds*) (%edit (cons val fun)))
        (#\f (cond
              ((null fun) nil)
              ((equal val fun) (pop *cmds*) (%edit fun))
              ((atom fun) fun)
              (t (cons (%edit (car fun)) (%edit (cdr fun)))))))))
   ((atom fun) (pop *cmds*) (%edit fun))
   ((eq (car *cmds*) #\d) (pop *cmds*) (%edit (cons (car fun) (%edit (cdr fun)))))
   ((eq (car *cmds*) #\a) (pop *cmds*) (%edit (cons (%edit (car fun)) (cdr fun))))
   ((eq (car *cmds*) #\x) (pop *cmds*) (%edit (cdr fun)))
   (t fun)))

(defun edit (name)
  (let ((fun (eval name))
        cc)
    (setq *cmds* nil)
    (loop
     (write-byte 12)
     (setq cc (append cc (list #\h)))
     (setq *cmds* cc)
     (pprint (%edit fun))
     (setq cc (butlast cc))
     (let ((c (get-key)))
       (case c
         (#\q (set name fun) (return name))
         (#\s (setq *cmds* cc) (set name (%edit fun)) (return name))
         (#\z (when cc (setq cc (butlast cc))))
         ((#\r #\c #\i #\f #\e)
          (write-byte 11) (princ c) (princ #\:)
          (setq cc (append cc (list (cons c (read))))))
         ((#\d #\a #\x #\b)
          (setq cc (append cc (list c))))
         (t (write-byte 7)))))))

(defun write-text (str)
 (with-gfx (scr)
  (princ str scr)))

(defvar SCR-W 320)
(defvar SCR-H 240)

(defun rgb (r g b) (logior (ash (logand r #xf8) 8) (ash (logand g #xfc) 3) (ash b -3)))
(defvar code_col   (rgb 220  220  220))
(defvar line_col   (rgb 90  90  90))
(defvar header_col (rgb 140  140  140))
(defvar border_col (rgb 63  40  0))
(defvar bg_col     (rgb 0  0  0))
(defvar cursor_col (rgb 160  60  0))

(defvar tscale 1)
(defvar leading (* 10 tscale))
(defvar cwidth (* 6 tscale))

(defun obj:window (x y w h &optional title)
  (let* ((set-pos_ (lambda (x_ y_) (setf x x_ y y_)))
	 (set-size_ (lambda (w_ h_) (setf w w_ h h_))))
	(lambda (&rest messages)
		(case (car messages)
		  (x x)
		  (y y)
		  (w w)
		  (h h)
		  (title title)
		  (in-x (+ x 5))
		  (in-y (if title (+ y 5 3 leading) (+ y 5)))
		  (in-w (- w 5))
		  (in-h (if title (- h 5 3 leading) (- h 5)))
		  (set-pos (apply set-pos_ (cdr messages)))
		  (set-size (apply set-size_ (cdr messages)))
		  (set-title (setf title (cadr messages)))

		  (draw-border
		   (fill-rect x y w h bg_col)
		   (draw-rect x y w h border_col)
		   (when title
		    (draw-rect x y w (+ 3 leading) border_col  )
			  (set-text-color header_col bg_col )
			  (set-cursor (+ x 5)  (+ y 3))
			  (write-text title)))))))

(defun obj:txtwindow (x y w h &optional title)
 (let* ((win (obj:window x y w h title))
	(tmax-x (lambda () (- (truncate (win 'in-w) cwidth) 1)))
	(tmax-y (lambda () (truncate (win 'in-h) leading)))
	(disp-line_ (lambda (line y &optional is_selected)
		     (let ((ypos (+ (win 'in-y) (* y leading)))  (myl " "))
		      (when line
		       (setf myl (concatenate 'string line myl)))
		      (set-cursor (win 'in-x) ypos)
			(when (> (length myl) 0)
			 (if is_selected
			  (set-text-color code_col cursor_col)
			  (set-text-color code_col bg_col ))
			 (write-text (subseq myl 0 (min (length myl) (+ (tmax-x) 1)))))))))
  (lambda (&rest messages)
   (case (car messages)
     (disp-line (apply disp-line_ (cdr messages)))
     (txtmax (cons (tmax-x) (tmax-y)))
     (tmax-x (tmax-x))
     (tmax-y (tmax-y))
     (print (format t " txtmax ~a" (cons (tmax-x) (tmax-y))))
		(t (apply win messages))))))

(defun obj:menu (opts &optional (win (obj:txtwindow  0 0 100 100 )))
  (let* ((scroll 0)
	 (selected 0)
	 (show-opts_ (lambda (opts selected scroll)
		       (win 'draw-border)
		       (let ((i 0) (ymax (min (win 'tmax-y) (- (length opts) scroll))))
			 (loop
			   (win 'disp-line (princ-to-string (nth (+ scroll i) opts)) i  (= (- selected scroll)  i))
			   (incf i)
			   (when (>= i ymax) (return)))))))

    (lambda (&rest messages)
      (case (car messages)
	(show (show-opts_ opts selected scroll))
	(down (when (< selected (- (length opts) 1))
		(incf selected)
		(setf scroll (max (- selected (win 'tmax-y) -1) scroll))
		(show-opts_ opts selected scroll)))
	(up (when (> selected 0)
	      (decf selected)
	      (when (< selected scroll) (setf scroll selected))
	      (show-opts_ opts selected scroll)))
	(select (nth selected opts))
	(opts opts)
	(set-opts (setf opts (cadr messages))
		  (setf scroll 0) (setf selected 0))
	(print (format t "scroll: ~a selected: ~a txtmax ~a" scroll  selected (win 'txtmax)))
	(e (apply eval (cdr messages)))
	(t (apply win messages))))))


(defun split-line (str len)
  (let ((index 0) (lines nil))
    (loop
      (if (> (length str) (+ len index))
	(setf lines (append lines (list (subseq str index (+ index len)))))
	(return (append lines (list (subseq str index)))))
      (incf index len))))

(defun obj:textdisplay (text &optional (win (obj:txtwindow 0 0 100 100 )) )
  (let* ((scroll 0)
	 (show-text_ (lambda (buf scroll )
		       (win 'draw-border)
		       (let* ((i 0)
			      (lines (mapcan (lambda (x) (split-line x (win 'tmax-x))) buf))
			      (ymax (min (win 'tmax-y) (- (length lines) scroll))))
			 (loop
			   (win 'disp-line (nth (+ scroll i) lines) i)
				  (incf i)
				  (when (>= i ymax) (return)))))))

    (lambda (&rest messages)
      (case (car messages)
	(text text)
	(set-text (setf text (cadr messages)))
	(show (show-text_ text scroll))
	(print (format t "scroll: ~a txtmax ~a" scroll (win 'txtmax)))
	(t (apply win messages))))))


(defun get-doc-text (keyword)
  (let ((doc-str (documentation keyword )))
    (if doc-str
      (split-string-to-list (string #\Newline)
			    (format nil "~a~%~%" doc-str))
      (list (concatenate 'string "No doc for " (string keyword))))))

(defun update-doc ()
  (doc 'set-text (get-doc-text (menu 'select)))
  (doc 'set-title (menu 'select))
  (doc 'show))

(defun update-menu ()
  (menu 'set-opts (apropos-list search))
  (menu 'set-title search)
  (menu 'show))

(defun doc-browser ()
  (let* ((lastkey nil) (exit nil)
		       (menu (obj:menu (apropos-list "") (obj:txtwindow 0 0 (truncate (* SCR-W .33)) SCR-H "")))
		       (doc (obj:textdisplay (get-doc-text (menu 'select))
					     (obj:txtwindow  (truncate (* SCR-W .33)) 0  (truncate (* SCR-W .66)) SCR-H (string (menu 'select)))))
		       (search ""))

    (menu 'show)
    (doc 'show)
    (loop
      (setf lastkey (keyboard-get-key))
      (when lastkey
	(case lastkey
	  (218 (menu 'up) (update-doc))
	  (217 (menu 'down) (update-doc))
	  (216 'left)
	  (215 'right)
	  ((or 13 10) 'enter (setf exit t) (setf lastkey nil))
	  ((or 3 17)  (setf exit t) (setf lastkey nil))
	  ((or 8 127)
	   (when (> (length search) 0)
	     (setf search (subseq search 0 (- (length search) 1)))
	     (update-menu)
	     (update-doc)))
	  (t (when (printable lastkey)
	       (setf search (concatenate 'string search (string (code-char lastkey))))
	       (update-menu)
	       (update-doc)))))
      (when exit
	(fill-screen)
	(return  (menu 'select))))))

(defun split-string-to-list (delim str)
  (unless (or (eq str nil) (not (stringp str)))
    (let* ((start 0)
	   (end (search-str delim str))
	   (lst nil))
      (loop
	(if (eq end nil)
	  (return (append lst (list (subseq str start))))
	  (setq lst (append lst (list (subseq str start end)))))
	(setq start (1+ end))
	(setq end (search-str delim str start))))))

(defun printable (chr)
  (if (and (> chr 31) (< chr 127))
    t
    nil))

(defun battery ()
  "(battery)
Returns the current battery reading."
  (+ 0.2 (*
	   (analogread 4)
	   (/ 6.6 4095.0))))

)
)lisplibrary";
