kyle
/
ulisp
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

set up unified lisp library and extensions subsystem.

This commit is contained in:
Kyle Isom 2025-04-11 01:17:32 -07:00
parent 2510da3f4a
commit f6c22d170a
9 changed files with 310 additions and 726 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.gitignore vendored
View File

@ -1,4 +1,14 @@
secrets.lsp # put wifi credentials or other stuff here
lisp/secrets.lsp
# build outputs
*/build */build
**/*.uf2 **/*.uf2
*/*.patch */*.patch
*/LispLibrary.h
common/genlib
*/extensions.ino
!common/extensions.ino
# darwin-specific
common/genlib.dSYM

19
README.org Normal file
View File

@ -0,0 +1,19 @@
#+TITLE: uLisp development
* uLisp development tree
** Tree imports
| platform | commit-id | upstream |
| ========== | =========== | ============= |
| picocalc | 25199750cf3e01c4537b9f2ffafbc3afa3499bc1 | personal repo |
| t-deck | 895fdfe40d931b519aa4bfdf0f32f75b70dd56c4 | personal repo |
| teensy | 75b2785b5adebe7ae3dd9f8a69bccedd733484e5 | author repo |
| ulisp-builder | 8a83566f2a5454faa23c039e5377055a16a3d804 | author repo |
** Platforms
*** picocalc:
*** teensy:
*** t-deck
*** builder

33
common/Makefile Normal file
View File

@ -0,0 +1,33 @@
LISPS := $(wildcard *.lsp)
SOURCE := extensions.ino
OUTPUT := LispLibrary.h
TARGET := genlib
PLATFORMS := picocalc tdeck teensy
TARGETS_LIB := $(addprefix ../,$(addsuffix /$(OUTPUT),$(PLATFORMS)))
TARGETS_EXT := $(addprefix ../,$(addsuffix /$(SOURCE),$(PLATFORMS)))
CFLAGS += -Wall -Wextra -pedantic -Wshadow -Werror -std=c99 -g
.PHONY: all
all: $(TARGET)
.PHONY: all
install: $(TARGETS_LIB) $(TARGETS_EXT)
.PHONY: clean
clean:
rm $(OUTPUT) $(TARGET)
$(TARGET): $(LISPS) $(SOURCE) $(TARGET).c Makefile
$(CC) $(CFLAGS) -o $(TARGET) $(TARGET).c
$(OUTPUT): $(TARGET) $(LISPS) $(SOURCE) Makefile
$(TARGETS_LIB): $(OUTPUT)
cp $(OUTPUT) $@
$(TARGETS_EXT): $(SOURCE)
cp $(SOURCE) $@
print-%: ; @echo '$(subst ','\'',$*=$($*))'

2
tdeck/ulisp-extensions.ino → common/extensions.ino
View File

@ -1,5 +1,5 @@
/* /*
User Extensions User Extensions
LispBox uLisp Extension - Version 1.0 - June 2024 LispBox uLisp Extension - Version 1.0 - June 2024
Hartmut Grawe - github.com/ersatzmoco - June 2024 Hartmut Grawe - github.com/ersatzmoco - June 2024

219
common/genlib.c Normal file
View File

@ -0,0 +1,219 @@
/*
* genlib.c: generate unified LispLibrary.h for the various uLisp
* platforms I work on.
*/
#include <errno.h>
#include <fcntl.h>
#include <limits.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <unistd.h>
#include <sys/stat.h>
#define MAX_FILENAME 256
#define MAX_STRFTIME 32
#define BUFFER_SIZE 4096
const char lisp_output[] = "LispLibrary.h";
/*
* Determines whether a directory exists.
*/
int
path_exists(const char *path)
{
struct stat st;
int rv;
rv = stat(path, &st);
if (rv == -1) {
return 0;
}
if (st.st_mode & S_IFDIR) {
return 1;
}
else if (st.st_mode & S_IFREG) {
return 1;
}
return 1;
}
/*
* Unlike some other functions, it is an error to call copy_library if the path
* doesn't exist. Other functions (such as copy_platform_library) will validate
* the file exists first and skip it if it doesn't.
*/
static int
copy_library(const char *filename, int source_fd)
{
char buffer[BUFFER_SIZE];
ssize_t bytes_read = 0;
ssize_t bytes_written = 0;
int fd = -1;
fd = open(filename, O_RDONLY);
if (fd == -1) {
return -1;
}
while ((bytes_read = read(fd, buffer, sizeof(buffer))) > 0) {
bytes_written = write(source_fd, buffer, bytes_read);
if (bytes_written != bytes_read) {
close(fd);
return -1;
}
}
if (bytes_read == -1) {
close(fd);
return -1;
}
close(fd);
return 0;
}
static int
copy_platform_library(const char *platform, int dest_fd) {
char filename[MAX_FILENAME];
if (!platform || !*platform) {
errno = EINVAL;
return -1;
}
printf("[+] attempting to load %s-specific library...\n",
platform);
if (snprintf(filename, sizeof(filename), "%s.lsp", platform) >=
(int)sizeof(filename)) {
errno = ENAMETOOLONG;
return -1;
}
if (!path_exists(filename)) {
printf("\t[+] %s-specific library not found; skipping.\n",
platform);
return 0;
}
dprintf(dest_fd, "(when (eq (platform) :%s)", platform);
if (copy_library(filename, dest_fd) != 0) {
perror("[!] copying failed");
return -1;
}
dprintf(dest_fd, ")\n");
return 0;
}
static void
write_preamble(int dest_fd)
{
char timestamp[MAX_STRFTIME+1];
struct tm tm;
time_t now = time(NULL);
localtime_r(&now, &tm);
dprintf(dest_fd,
"/*\n"
" * LispLibrary.h - builtin library of additional uLisp functions\n"
" *\n"
" * NOTE:\n"
" * this file was automatically generated on %s\n"
" *\n"
" * Changes will not be persisted across builds or platforms.\n"
" */\n\n"
"const char LispLibrary[] PROGMEM = R\"lisplibrary(\n\n",
timestamp);
}
static void
write_epilogue(int dest_fd)
{
dprintf(dest_fd, "\n)lisplibrary\";\n");
}
static void
usage(int status)
{
FILE *output = stdout;
if (status != 0) {
output = stderr;
}
fprintf(output, "Usage: genlib [-h]\n"
""
"Generates a unified LispLibrary.h for the various platforms.\n");
exit(status);
}
int
main(int argc, const char *argv[])
{
int fd = -1;
int ch;
while ((ch = getopt(argc, (char **)argv, "h")) != -1) {
switch (ch) {
case 'h':
usage(0);
break;
default:
usage(1);
}
}
argc -= optind;
argv += optind;
fd = open(lisp_output, O_WRONLY|O_CREAT, 0644);
if (fd == -1) {
perror("[!] failed to open library for write");
exit(1);
}
write_preamble(fd);
if (copy_library("library.lsp", fd) != 0) {
fprintf(stderr, "[!] failed to generate %s.\n", lisp_output);
exit(1);
}
if (copy_platform_library("picocalc", fd) != 0) {
fprintf(stderr, "[!] failed to generate the picocalc component.\n");
exit(1);
}
if (copy_platform_library("t-deck", fd) != 0) {
fprintf(stderr, "[!] failed to generate the picocalc component.\n");
exit(1);
}
if (copy_platform_library("teensy", fd) != 0) {
fprintf(stderr, "[!] failed to generate the picocalc component.\n");
exit(1);
}
write_epilogue(fd);
close(fd);
}

0
tdeck/library.lsp → common/library.lsp
View File

0
tdeck/tdeck.lsp → common/t-deck.lsp
View File

215
picocalc/LispLibrary.h
View File

@ -1,215 +0,0 @@
// Library of additional Lisp functions with integral documentation
// LispLibrary.h - Version 2 - 5th November 2023
const char LispLibrary[] PROGMEM = R"lisplibrary(
(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 ((lst nil))
(loop
(let ((form (read str)))
(unless form (return))
(setf lst (cons (second form) lst))
(eval form)))
(reverse lst))))
(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."
(nconc 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")))
)lisplibrary";

482
tdeck/LispLibrary.h
View File

@ -1,482 +0,0 @@
// 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";