From f6c22d170ae24d590ba45a7eb6970599bbf2070b Mon Sep 17 00:00:00 2001 From: Kyle Isom Date: Fri, 11 Apr 2025 01:17:32 -0700 Subject: [PATCH] set up unified lisp library and extensions subsystem. --- .gitignore | 12 +- README.org | 19 + common/Makefile | 33 ++ .../extensions.ino | 56 +- common/genlib.c | 219 ++++++++ {tdeck => common}/library.lsp | 0 tdeck/tdeck.lsp => common/t-deck.lsp | 0 picocalc/LispLibrary.h | 215 -------- tdeck/LispLibrary.h | 482 ------------------ 9 files changed, 310 insertions(+), 726 deletions(-) create mode 100644 README.org create mode 100644 common/Makefile rename tdeck/ulisp-extensions.ino => common/extensions.ino (97%) create mode 100644 common/genlib.c rename {tdeck => common}/library.lsp (100%) rename tdeck/tdeck.lsp => common/t-deck.lsp (100%) delete mode 100644 picocalc/LispLibrary.h delete mode 100644 tdeck/LispLibrary.h diff --git a/.gitignore b/.gitignore index e79ee4e..c63b334 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,14 @@ -secrets.lsp +# put wifi credentials or other stuff here +lisp/secrets.lsp + +# build outputs */build **/*.uf2 */*.patch +*/LispLibrary.h +common/genlib +*/extensions.ino +!common/extensions.ino + +# darwin-specific +common/genlib.dSYM diff --git a/README.org b/README.org new file mode 100644 index 0000000..ab9a4df --- /dev/null +++ b/README.org @@ -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 diff --git a/common/Makefile b/common/Makefile new file mode 100644 index 0000000..0136617 --- /dev/null +++ b/common/Makefile @@ -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 ','\'',$*=$($*))' diff --git a/tdeck/ulisp-extensions.ino b/common/extensions.ino similarity index 97% rename from tdeck/ulisp-extensions.ino rename to common/extensions.ino index 9e4f284..0f3c5eb 100644 --- a/tdeck/ulisp-extensions.ino +++ b/common/extensions.ino @@ -1,5 +1,5 @@ /* - User Extensions + User Extensions LispBox uLisp Extension - Version 1.0 - June 2024 Hartmut Grawe - github.com/ersatzmoco - June 2024 @@ -34,7 +34,7 @@ bcd_to_dec(uint8_t n) /* * STANDARD DEFINITIONS - * + * * These definitions should be the same on every platform. */ object * @@ -143,17 +143,17 @@ hyperprint(object *form, int lm, pfun_t pfun) } while (form != NULL) { - if (atom(form)) { - pfstring(PSTR(" . "), pfun); + if (atom(form)) { + pfstring(PSTR(" . "), pfun); printobject(form, pfun); pfun(')'); return; - } else if (separate) { + } else if (separate) { pfun('('); separate = false; } else if (special) { pfun(' '); - special--; + special--; } else if (fits) { pfun(' '); } else { @@ -288,7 +288,7 @@ fn_searchn(object *args, object *env) object *pattern = first(args); object *target = second(args); - if (cddr(args) != NULL) { + if (cddr(args) != NULL) { object *num = third(args); if (integerp(num)) { @@ -311,7 +311,7 @@ fn_searchn(object *args, object *env) target1 = cdr(target1); } - if (pattern == NULL){ + if (pattern == NULL){ last_index = i; if (matches-- == 0) { @@ -335,7 +335,7 @@ fn_searchn(object *args, object *env) j++; } - if (j == m) { + if (j == m) { last_index = i; if(matches-- == 0){ return number(i); @@ -365,7 +365,7 @@ fn_sd_rename(object *args, object *env) (void) env; char buffer1[BUFFERSIZE]; char buffer2[BUFFERSIZE]; - + object *pathFrom = car(args); if (!stringp(pathFrom)) { @@ -390,7 +390,7 @@ fn_sd_remove(object *args, object *env) { (void) env; char buffer[BUFFERSIZE]; - + object *arg = car(args); if (!SD.remove(MakeFilename(arg, buffer))) { @@ -406,7 +406,7 @@ fn_sd_existsp(object *args, object *env) (void) env; char buffer[BUFFERSIZE]; - + object *arg = car(args); if (!SD.exists(MakeFilename(arg, buffer))) { return nil; @@ -417,15 +417,15 @@ fn_sd_existsp(object *args, object *env) /* (sd-make-dir path) - Create a directory on the SD card. - This will also create any intermediate directories that don’t already exists; + Create a directory on the SD card. + This will also create any intermediate directories that don’t already exists; e.g. SD.mkdir("a/b/c") will create a, b, and c. */ object * fn_sd_mkdir(object *args, object *env) { (void) env; - + char buffer[BUFFERSIZE]; object *arg = car(args); @@ -465,17 +465,17 @@ fn_sd_list(object *args, object *env) { (void) env; - char *sd_path_buf = NULL; + char *sd_path_buf = NULL; SDBegin(); - File root; + File root; object *result = cons(NULL, NULL); object *ptr = result; if (args != NULL) { object *arg1 = checkstring(first(args)); int len = stringlength(arg1) + 2; //make it longer for the initial slash and the null terminator - sd_path_buf = (char*)malloc(len); + sd_path_buf = (char*)malloc(len); if (sd_path_buf != NULL) { cstring(arg1, &sd_path_buf[1], len-1); @@ -705,16 +705,16 @@ touchKeyModEditor(char temp) #if defined (touchscreen) /* t-deck / blackberry keyboard missing symbols missing mapped alt symbol - ` k ' - ~ p @ - % $ - ^ a * - & q # - = o + - < t ( - > y ) - \ u _ - | g / + ` k ' + ~ p @ + % $ + ^ a * + & q # + = o + + < t ( + > y ) + \ u _ + | g / [ alt-t ( ] alt-y ) diff --git a/common/genlib.c b/common/genlib.c new file mode 100644 index 0000000..150520a --- /dev/null +++ b/common/genlib.c @@ -0,0 +1,219 @@ +/* + * genlib.c: generate unified LispLibrary.h for the various uLisp + * platforms I work on. + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include + + +#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); +} diff --git a/tdeck/library.lsp b/common/library.lsp similarity index 100% rename from tdeck/library.lsp rename to common/library.lsp diff --git a/tdeck/tdeck.lsp b/common/t-deck.lsp similarity index 100% rename from tdeck/tdeck.lsp rename to common/t-deck.lsp diff --git a/picocalc/LispLibrary.h b/picocalc/LispLibrary.h deleted file mode 100644 index 076f41e..0000000 --- a/picocalc/LispLibrary.h +++ /dev/null @@ -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"; diff --git a/tdeck/LispLibrary.h b/tdeck/LispLibrary.h deleted file mode 100644 index 547f595..0000000 --- a/tdeck/LispLibrary.h +++ /dev/null @@ -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";