16 files changed, 586 insertions, 0 deletions

@@ -0,0 +1,5 @@
+*.build.sh
+*.so
+*.link
+*.o
+*.import.scm
\ No newline at end of file
@@ -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.")
@@ -0,0 +1,7 @@
+.PHONY: install
+install:
+        chicken-install
+
+.PHONY: clean
+clean:
+        rm -f *.so *.o *.link *.build.sh
@@ -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
@@ -0,0 +1,7 @@
+(define-library (yolk colors)
+  (export colors-reset
+          color?
+          colors
+          with-colors)
+
+  (include "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)))))
@@ -0,0 +1,9 @@
+(define-library (yolk common)
+  (export esc
+          csi
+          dcs
+          ocs
+          define-esc-alt-wrapper
+          parameter-assert)
+
+  (include "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))))
@@ -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"))
@@ -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)
@@ -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))))
@@ -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"))
@@ -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"))
@@ -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' <<ENDINFO
+((installed-files
+   "/home/acdw/usr/lib/chicken/11/yolk.common.o"
+   "/home/acdw/usr/lib/chicken/11/yolk.common.link"
+   "/home/acdw/usr/lib/chicken/11/yolk.common.so"
+   "/home/acdw/usr/lib/chicken/11/yolk.common.import.so"
+   "/home/acdw/usr/lib/chicken/11/yolk.cursor.o"
+   "/home/acdw/usr/lib/chicken/11/yolk.cursor.link"
+   "/home/acdw/usr/lib/chicken/11/yolk.cursor.so"
+   "/home/acdw/usr/lib/chicken/11/yolk.cursor.import.so"
+   "/home/acdw/usr/lib/chicken/11/yolk.erase.o"
+   "/home/acdw/usr/lib/chicken/11/yolk.erase.link"
+   "/home/acdw/usr/lib/chicken/11/yolk.erase.so"
+   "/home/acdw/usr/lib/chicken/11/yolk.erase.import.so"
+   "/home/acdw/usr/lib/chicken/11/yolk.xterm.o"
+   "/home/acdw/usr/lib/chicken/11/yolk.xterm.link"
+   "/home/acdw/usr/lib/chicken/11/yolk.xterm.so"
+   "/home/acdw/usr/lib/chicken/11/yolk.xterm.import.so")
+ (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.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))))
+ENDINFO
@@ -0,0 +1,11 @@
+;;; (yolk xterm) --- xterm private mode settings
+
+(define-library (yolk xterm)
+  (export invisible-cursor
+          visible-cursor
+          save-screen
+          restore-screen
+          alt-buffer-enable
+          alt-buffer-disable)
+
+  (include "yolk.xterm.ss"))
@@ -0,0 +1,22 @@
+(import (scheme base)
+        (yolk common))
+
+;;; Common private modes
+
+(define invisible-cursor
+  (csi "?25l"))
+
+(define visible-cursor
+  (csi "?25h"))
+
+(define save-screen
+  (csi "?47h"))
+
+(define restore-screen
+  (csi "?47l"))
+
+(define alt-buffer-enable
+  (csi "?1049h"))
+
+(define alt-buffer-disable
+  (csi "?1049l"))