From 82a6e29eaad2944eb2e1a2213a9bce17e896add4 Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Sun, 28 May 2023 21:47:09 -0500 Subject: initial commit --- .gitignore | 5 +++ .repl | 29 ++++++++++++ makefile | 7 +++ readme | 136 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ yolk.colors.sld | 7 +++ yolk.colors.ss | 89 ++++++++++++++++++++++++++++++++++++ yolk.common.sld | 9 ++++ yolk.common.ss | 39 ++++++++++++++++ yolk.cursor.sld | 15 +++++++ yolk.cursor.ss | 60 +++++++++++++++++++++++++ yolk.egg | 27 +++++++++++ yolk.erase.sld | 13 ++++++ yolk.erase.ss | 26 +++++++++++ yolk.install.sh | 91 +++++++++++++++++++++++++++++++++++++ yolk.xterm.sld | 11 +++++ yolk.xterm.ss | 22 +++++++++ 16 files changed, 586 insertions(+) create mode 100644 .gitignore create mode 100644 .repl create mode 100644 makefile create mode 100644 readme create mode 100644 yolk.colors.sld create mode 100644 yolk.colors.ss create mode 100644 yolk.common.sld create mode 100644 yolk.common.ss create mode 100644 yolk.cursor.sld create mode 100644 yolk.cursor.ss create mode 100644 yolk.egg create mode 100644 yolk.erase.sld create mode 100644 yolk.erase.ss create mode 100644 yolk.install.sh create mode 100644 yolk.xterm.sld create mode 100644 yolk.xterm.ss diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..eea9250 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +*.build.sh +*.so +*.link +*.o +*.import.scm \ No newline at end of file diff --git a/.repl b/.repl new file mode 100644 index 0000000..8adbefe --- /dev/null +++ b/.repl @@ -0,0 +1,29 @@ +;;; -*- scheme -*- + +#+chicken (import (r7rs)) + +(import (scheme file)) + +;;; Load libraries + +(let loop ((load-files '("yolk.common" + "yolk.colors" + "yolk.cursor" + "yolk.erase" + "yolk.xterm"))) + (if (null? load-files) + #t + (let* ((this (car load-files)) + (ss (string-append (car load-files) ".ss")) + (sld (string-append (car load-files) ".sld"))) + (and (file-exists? ss) + (load ss)) + ;(eval `(import ,(map string->symbol (string-split this ".")))) + (and (file-exists? sld) + (load sld)) + (loop (cdr load-files))))) + +;;; Set up a test environment + +;;; Done. +(print "Ready.") diff --git a/makefile b/makefile new file mode 100644 index 0000000..05522f6 --- /dev/null +++ b/makefile @@ -0,0 +1,7 @@ +.PHONY: install +install: + chicken-install + +.PHONY: clean +clean: + rm -f *.so *.o *.link *.build.sh diff --git a/readme b/readme new file mode 100644 index 0000000..a98c60b --- /dev/null +++ b/readme @@ -0,0 +1,136 @@ +YOLK --- ansi escapes for CHICKEN -*- text -*- + +yes there's already ansi-escape-sequences[1]. consider this NIH ;) +this library is based on the information a gist by fnky[2]. +at some point i should base it instead on xterm's manual[3]. + +Unless otherwise stated, all procedures and variables in this library are +strings or return strings ready for `display'. + +INSTALLATION. + +Run `chicken-install' in this directory or `make install', which will run it for you. You can also run `make clean' to clean the folder of build artifacts. + +MODULES. + +(yolk common) --- common functionality + +Procedures. + +- (esc . xs) + +Return a string consisting of XS, converted to strings, prepended by ESC. + +- (csi . xs) + +Convenience function to escape XS using the csi code (ESC "["). + +- (dcs . xs) + +Convenience function to escape XS using the dcs code (ESC "P"). + +- (ocs . xs) + +Convenience function to escape XS using the ocs code (ESC "]"). + +- (parameter-assert predicate error-message) + +Convenience function. Returns a function that runs PREDICATE on its argument and +returns the argument if PREDICATE passes, or errors if not. I use this for +parameters. + +Syntax. + +- (define-esc-alt-wrapper wrapper-proc-name param-name (default-proc args ...)) + +Many terminal behaviors have multiple escape sequences that might work. This +macro defines a parameter named PARAM-NAME and a procedure named +WRAPPER-PROC-NAME that will call PARAM-NAME with ARGS ... . The user can change +which procedure to call by calling (PARAM-NAME new-proc). + +(yolk colors) --- NOT FINISHED + +There's a bug in this library. + +(yolk cursor) --- cursor movement + +Variables. + +-- cursor-home + +Move the cursor to the top-left corner (0,0). NOTE: This and the move commands +might be revised later. + +Procedures. + +-- (cursor-move x y) + +Move cursor to X, Y, counting from the top-left corner of the screen. +cursor-move is an esc-alt-wrapper that defaults to cursor-move/H ("^[[Y;XH"). + +-- (cursor-up n) +-- (cursor-down n) +-- (cursor-right n) +-- (cursor-left n) + +Move cursor up, down, left, or right by N spaces. + +-- (cursor-up-bol n) +-- (cursor-down-bol n) + +Move cursor up or down by N lines, to the beginning of the given line. + +-- (cursor-move-column n) + +Move cursor to column N. + +-- (cursor-save) +-- (cursor-restore) + +Save or restore the cursor's position on the screen. These variables are +parameters defaulting to the DEC escapes. You can set them to the SCO escapes +using (cursor-save cursor-save/sco), for example. + +(yolk erase) --- erasing the screen + +Variables. + +-- erase-screen-down +-- erase-screen-up +-- erase-screen +-- erase-saved-lines + +These erase portions of the entire screen. + +-- erase-line-right +-- erase-line-left +-- erase-line + +These erase portions of the current line. + +-- erase-line-and-return + +Convenience function to return the cursor to the beginning of the line after erasing it. + +(yolk xterm) --- xterm-specific escape sequences + +Variables. + +-- invisible-cursor +-- visible-cursor + +Make the cursor invisible or visible. + +-- save-screen +-- restore-screen + +Save or restore the screen's state. + +-- alt-buffer-enable +-- alt-buffer-disable + +Enable or disable the "alternate buffer." + +[1]: http://wiki.call-cc.org/eggref/5/ansi-escape-sequences +[2]: https://gist.github.com/fnky/458719343aabd01cfb17a3a4f7296797 +[3]: https://invisible-island.net/xterm/ctlseqs/ctlseqs.html diff --git a/yolk.colors.sld b/yolk.colors.sld new file mode 100644 index 0000000..44d7593 --- /dev/null +++ b/yolk.colors.sld @@ -0,0 +1,7 @@ +(define-library (yolk colors) + (export colors-reset + color? + colors + with-colors) + + (include "yolk.colors.ss")) diff --git a/yolk.colors.ss b/yolk.colors.ss new file mode 100644 index 0000000..70b821b --- /dev/null +++ b/yolk.colors.ss @@ -0,0 +1,89 @@ +;;; (yolk colors) --- ansi color escapes + +;; "Colors" in this context refers both to actual /colors/, and to text +;; properties like bold, italic, etc. + +(import (scheme base) + (scheme write) + (chicken string) + (matchable) ; is this something i want? + (yolk common)) + +(define (%colors . codes) + (let ((codestr (string-intersperse (map ->string codes) ";"))) + (csi codestr "m"))) + +(define %props-alist + '((reset . "0") + ;; name . (on . off) + (bold . ("1" . "22")) + (dim . ("2" . "22")) + (italic . ("3" . "23")) + (underline . ("4" . "24")) + (blink . ("5" . "25")) + (inverse . ("7" . "27")) + (hidden . ("8" . "28")) + (strikethrough . ("9" . "29")))) + +(define %colors-alist + '((reset . "0") + ;; color . (fg . bg) + (black . ("30" . "40")) + (red . ("31" . "41")) + (green . ("32" . "42")) + (yellow . ("33" . "43")) + (blue . ("34" . "44")) + (magenta . ("35" . "45")) + (cyan . ("36" . "46")) + (white . ("37" . "47")) + (default . ("39" . "49")))) + +(define (atom? x) + (and (not (pair? x)) + (not (null? x)))) + +(define (colors-reset . codes) + (cond + ((null? codes) + (%colors 0)) + (else (apply string-append + (map (lambda (code) + (match code + ('fg (%colors (cadr (assq 'default %colors-alist)))) + ('bg (%colors (cddr (assq 'default %colors-alist)))) + (x (%colors (cddr (assq x %props-alist)))))) + codes))))) + +(define (color? x) + (memq x '(default black red green yellow blue magenta cyan white))) + +(define (colors codes) + (let loop ((codes codes) + (acc '())) + (if (null? codes) + (apply %colors (reverse acc)) + (loop (cdr codes) + (match (car codes) + ((? number? x) + (cons x acc)) + ((or `(fg ,color) + (? color? color)) + (cons (cadr (assq color %colors-alist)) + acc)) + (`(bg ,color) + (cons (cddr (assq color %colors-alist)) + acc)) + ((or `(set ,prop) + `(,prop on) + (? atom? prop)) + (cons (cadr (assq prop %props-alist)) + acc)) + ((or `(reset ,prop) + `(,prop off)) + (cons (cddr (assq prop %props-alist))))))))) + +(define (with-colors codes thunk) + (dynamic-wind + (lambda () (display (colors codes))) + thunk + (lambda () (display (colors-reset))))) diff --git a/yolk.common.sld b/yolk.common.sld new file mode 100644 index 0000000..94ac630 --- /dev/null +++ b/yolk.common.sld @@ -0,0 +1,9 @@ +(define-library (yolk common) + (export esc + csi + dcs + ocs + define-esc-alt-wrapper + parameter-assert) + + (include "yolk.common.ss")) diff --git a/yolk.common.ss b/yolk.common.ss new file mode 100644 index 0000000..00aa91e --- /dev/null +++ b/yolk.common.ss @@ -0,0 +1,39 @@ +;;; (yolk common) --- common stuff for ansi things + +(import (scheme base) + (scheme write)) + +(define (->string x) + (let ((str (open-output-string))) + (display x str) + (close-output-port str) + (get-output-string str))) + +(define (esc . xs) + (apply string-append (string #\escape) + (map ->string xs))) + +(define (csi . xs) + (apply esc "[" xs)) + +(define (dcs . xs) + (apply esc "P" xs)) + +(define (ocs . xs) + (apply esc "]" xs)) + +(define-syntax define-esc-alt-wrapper + (syntax-rules () + ((_ wrapper-proc-name param-name (default-proc args ...)) + (begin + (define param-name + (make-parameter default-proc + (parameter-assert procedure? "Must be a procedure"))) + (define (wrapper-proc-name args ...) + ((param-name) args ...)))))) + +(define (parameter-assert predicate error-message) + (lambda (x) + (if (predicate x) + x + (error error-message x)))) diff --git a/yolk.cursor.sld b/yolk.cursor.sld new file mode 100644 index 0000000..822720e --- /dev/null +++ b/yolk.cursor.sld @@ -0,0 +1,15 @@ +(define-library (yolk cursor) + (export cursor-home + cursor-move cursor-move-proc + cursor-move/H cursor-move/f + cursor-up + cursor-down + cursor-right + cursor-left + cursor-down-bol + cursor-up-bol + cursor-move-column + cursor-save cursor-save/dec cursor-save/sco + cursor-restore cursor-restore/dec cursor-restore/sco) + + (include "yolk.cursor.ss")) diff --git a/yolk.cursor.ss b/yolk.cursor.ss new file mode 100644 index 0000000..a61aa2f --- /dev/null +++ b/yolk.cursor.ss @@ -0,0 +1,60 @@ +;;; (yolk cursor) --- move the cursor around the terminal + +(import (scheme base) + (scheme case-lambda) + (yolk common)) + +(define cursor-home + (csi "H")) + +(define (cursor-move/H x y) + (csi y ";" x "H")) + +(define (cursor-move/f x y) + (csi y ";" x "f")) + +(define-esc-alt-wrapper cursor-move cursor-move-proc + (cursor-move/H x y)) + +(define (cursor-up n) + (csi n "A")) + +(define (cursor-down n) + (csi n "B")) + +(define (cursor-right n) + (csi n "C")) + +(define (cursor-left n) + (csi n "D")) + +(define (cursor-down-bol n) + (csi n "E")) + +(define (cursor-up-bol n) + (csi n "F")) + +(define (cursor-move-column n) + (csi n "G")) + +(define cursor-save/dec + (esc 7)) + +(define cursor-restore/dec + (esc 8)) + +(define cursor-save/sco + (csi "s")) + +(define cursor-restore/sco + (csi "u")) + +(define cursor-save + (make-parameter cursor-save/dec + (parameter-assert string? "Not a string"))) + +(define cursor-restore + (make-parameter cursor-restore/dec + (parameter-assert string? "Not a string"))) + +;; (define (get-cursor-postion) ...) ; (csi "6n"), reports as (csi r;cR) diff --git a/yolk.egg b/yolk.egg new file mode 100644 index 0000000..4e77939 --- /dev/null +++ b/yolk.egg @@ -0,0 +1,27 @@ +;;; yolk.egg --- ansi escapes for chicken -*- scheme -*- + +((synopsis "ANSI escapes for CHICKEN") + (author "Case Duckworth") + (category io) + (license "ISC") + (dependencies r7rs matchable) + (components + (extension yolk.common + (source "yolk.common.sld") + (csc-options "-R" "r7rs" "-X" "r7rs")) + #;(extension yolk.colors + (source "yolk.colors.sld") + (csc-options "-R" "r7rs" "-X" "r7rs") + (component-dependencies yolk.common)) + (extension yolk.cursor + (source "yolk.cursor.sld") + (csc-options "-R" "r7rs" "-X" "r7rs") + (component-dependencies yolk.common)) + (extension yolk.erase + (source "yolk.erase.sld") + (csc-options "-R" "r7rs" "-X" "r7rs") + (component-dependencies yolk.common)) + (extension yolk.xterm + (source "yolk.xterm.sld") + (csc-options "-R" "r7rs" "-X" "r7rs") + (component-dependencies yolk.common)))) diff --git a/yolk.erase.sld b/yolk.erase.sld new file mode 100644 index 0000000..7d449ec --- /dev/null +++ b/yolk.erase.sld @@ -0,0 +1,13 @@ +;;; (yolk erase) --- erasing ansi sequences + +(define-library (yolk erase) + (export erase-screen-down + erase-screen-up + erase-screen + erase-saved-lines + erase-line-right + erase-line-left + erase-line + erase-line-and-return) + + (include "yolk.erase.ss")) diff --git a/yolk.erase.ss b/yolk.erase.ss new file mode 100644 index 0000000..bc2d813 --- /dev/null +++ b/yolk.erase.ss @@ -0,0 +1,26 @@ +(import (scheme base) + (yolk common)) + +(define erase-screen-down + (csi "0J")) + +(define erase-screen-up + (csi "1J")) + +(define erase-screen + (csi "2J")) + +(define erase-saved-lines + (csi "3J")) + +(define erase-line-right + (csi "0K")) + +(define erase-line-left + (csi "1K")) + +(define erase-line + (csi "2K")) + +(define erase-line-and-return + (csi "2K\r")) diff --git a/yolk.install.sh b/yolk.install.sh new file mode 100644 index 0000000..beaf7a7 --- /dev/null +++ b/yolk.install.sh @@ -0,0 +1,91 @@ +#!/bin/sh + +set -e +cd '/home/acdw/src/yolk' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 644 '/home/acdw/src/yolk/yolk.xterm.static.o' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.xterm.o' +install -m 644 '/home/acdw/src/yolk/yolk.xterm.link' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.xterm.link' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 755 '/home/acdw/src/yolk/yolk.xterm.so' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.xterm.so' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 755 '/home/acdw/src/yolk/yolk.xterm.import.so' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.xterm.import.so' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 644 '/home/acdw/src/yolk/yolk.erase.static.o' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.erase.o' +install -m 644 '/home/acdw/src/yolk/yolk.erase.link' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.erase.link' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 755 '/home/acdw/src/yolk/yolk.erase.so' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.erase.so' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 755 '/home/acdw/src/yolk/yolk.erase.import.so' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.erase.import.so' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 644 '/home/acdw/src/yolk/yolk.cursor.static.o' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.cursor.o' +install -m 644 '/home/acdw/src/yolk/yolk.cursor.link' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.cursor.link' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 755 '/home/acdw/src/yolk/yolk.cursor.so' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.cursor.so' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 755 '/home/acdw/src/yolk/yolk.cursor.import.so' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.cursor.import.so' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 644 '/home/acdw/src/yolk/yolk.common.static.o' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.common.o' +install -m 644 '/home/acdw/src/yolk/yolk.common.link' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.common.link' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 755 '/home/acdw/src/yolk/yolk.common.so' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.common.so' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +install -m 755 '/home/acdw/src/yolk/yolk.common.import.so' "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.common.import.so' + +mkdir -p "${DESTDIR}"'/home/acdw/usr/lib/chicken/11' +rm -f "${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.egg-info' +cat >"${DESTDIR}"'/home/acdw/usr/lib/chicken/11/yolk.egg-info' <