the t-deck arises
This commit is contained in:
parent
641c9480c7
commit
7d5d4a9558
|
|
@ -0,0 +1,482 @@
|
|||
// 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";
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
# uLisp T-Deck
|
||||
A version of uLisp to convert the LilyGO T-Deck into a self-contained handheld Lisp computer.
|
||||
|
||||
For more information see [LilyGO T-Deck uLisp Machine](http://www.ulisp.com/show?4JAO).
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
#!/usr/bin/env python3
|
||||
|
||||
def read_lib(path):
|
||||
with open(path, 'rt') as source:
|
||||
return "".join([line for line in source.readlines() if not line.startswith(';')])
|
||||
|
||||
with open('LispLibrary.h', 'wt') as lib_header:
|
||||
lib_header.write(f"""// Library of additional Lisp functions with integral documentation
|
||||
// LispLibrary.h - Version 2 - 5th November 2023
|
||||
|
||||
const char LispLibrary[] PROGMEM = R"lisplibrary(
|
||||
{read_lib('library.lsp')}
|
||||
(when (eq (platform) :t-deck)
|
||||
{read_lib('tdeck.lsp')}
|
||||
)
|
||||
)lisplibrary";
|
||||
""")
|
||||
|
|
@ -0,0 +1,228 @@
|
|||
(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")))
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
#!/usr/bin/env python3
|
||||
|
||||
import os.path
|
||||
import serial
|
||||
import time
|
||||
import sys
|
||||
|
||||
CHUNK_SIZE=8
|
||||
LISP='xfer.lsp'
|
||||
|
||||
def chunkstring(string, length):
|
||||
return (string[0+i:length+i] for i in range(0, len(string), length))
|
||||
|
||||
def chunkfile(path):
|
||||
with open(path, 'rt') as source:
|
||||
return list(chunkstring(source.read(), CHUNK_SIZE))
|
||||
|
||||
def readfile(path):
|
||||
with open(path, 'rt') as source:
|
||||
return source.read()
|
||||
|
||||
def select_candidate(clst):
|
||||
for cand in clst:
|
||||
if os.path.exists(cand):
|
||||
print(f'[+] {cand}')
|
||||
return cand
|
||||
return None
|
||||
|
||||
candidates = ['/dev/ttyUSB0', '/dev/ttyACM0', '/dev/tty.usbmodem2101']
|
||||
candidate = select_candidate(candidates)
|
||||
seriell = serial.Serial(port=candidate, baudrate=9600)
|
||||
if len(sys.argv) > 1:
|
||||
paths = sys.argv[1:]
|
||||
else:
|
||||
paths = [LISP,]
|
||||
for path in paths:
|
||||
chunked = readfile(path)
|
||||
for chunk in chunked:
|
||||
print(chunk)
|
||||
seriell.write(chunk.encode('ascii'))
|
||||
time.sleep(0.1)
|
||||
|
||||
|
|
@ -0,0 +1,245 @@
|
|||
(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))))
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue