246 lines
7.7 KiB
Common Lisp
246 lines
7.7 KiB
Common Lisp
(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))))
|