ian/dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Tmux etc

Browse source
This commit is contained in:
Ian Keane 2020-02-18 14:21:14 -05:00
parent 276853ba84
commit 1cb167b597
361 changed files with 77302 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

239
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/add_wch.lisp Normal file
View file

@ -0,0 +1,239 @@
(in-package :de.anvi.croatoan)
(defun add-wide-char-utf-8 (window char &key attributes color-pair y x position n)
"Add the wide (multi-byte) char to the window, then advance the cursor.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the character.
The position can also be passed in form of a two-element list.
If n is given, write n chars. If n is -1, as many chars will be added
as will fit on the line."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((count (if n
(if (= n -1)
(distance-to-eol window)
n)
1))
(code-point (typecase char
(integer char)
(character (char-code char)))))
(typecase char
(complex-char
;; if we have a complex char, use its own attributes and colors.
(loop repeat count do
(mapc #'(lambda (ch) (add-char window ch :attributes (attributes char) :color-pair (color-pair char)))
(unicode-to-utf-8 (char-code (simple-char char))))))
;; if we have a lisp char or an integer, use the attributes and colors passed as arguments.
(t
(loop repeat count do
(mapc #'(lambda (ch) (add-char window ch :attributes attributes :color-pair color-pair))
(unicode-to-utf-8 code-point)))))))
;; we can use this for add-wide-char, echo-wide-char, insert-wide-char, set-wide-background-char
(defun funcall-make-cchar_t-ptr (fn winptr char attr_t color-pair-number count)
"Create a cchar_t and apply function fn count times to winptr and cchar_t.
cchar_t is a C struct representing a wide complex-char in ncurses.
This function is a wrapper around %setcchar and should not be used elsewhere."
(with-foreign-objects ((ptr '(:struct cchar_t))
(wch 'wchar_t 5))
(dotimes (i 5) (setf (mem-aref wch 'wchar_t i) 0))
(setf (mem-aref wch 'wchar_t) char)
(%setcchar ptr wch attr_t color-pair-number (null-pointer))
(if (= count 1)
(funcall fn winptr ptr)
(dotimes (i count) (funcall fn winptr ptr)) )))
(defun funcall-make-cchar_t (fn window char attributes color-pair n)
"Assemble a cchar_t out of a char, attributes and a color-pair.
Then apply the fn to window and the assembled cchar_t.
char can be a lisp character, an ACS keyword, an integer code point or
a complex char.
attributes should be a list of valid attribute keywords.
color-pair should be a list of a foreground and background color keyword.
attributes and color-pair can be nil.
If char is a complex char, attributes and color-pair are ignored."
(let ((winptr (winptr window))
(ch
(typecase char
;; if we have a lisp char or an integer, use the attributes and colors passed as arguments.
(integer char)
(character (char-code char))
(keyword (wacs char))
;; if we have a complex char, use its own attributes and colors.
(complex-char (if (simple-char char)
(let ((sch (simple-char char)))
(typecase sch
(integer sch)
(character (char-code sch))
(keyword (wacs sch))
(otherwise (error "unknown character type"))))
;; this means that the default simple char is space, otherwise
;; we can not set complex background chars.
;; TODO: set this here or as initform for complex-char?
32))
(otherwise (error "unknown character type"))))
(attr_t
(typecase char
(complex-char (attrs2chtype (attributes char)))
(otherwise (attrs2chtype attributes))))
;; we just need the pair number here, NOT the bit-shifted color attribute.
;; we need the color attribute for chtypes.
(color-pair-number
(if (or (eq fn #'%wbkgrnd)
(eq fn #'%wbkgrndset))
;; when setting the background, do not complete using the windows color pair and background
;; just complete from the default pair
(pair-to-number (complete-default-pair (typecase char
(complex-char (color-pair char))
(otherwise color-pair))))
;; for every other function, complete from the full sequence
(pair-to-number (complete-pair window (typecase char
(complex-char (color-pair char))
(otherwise color-pair))))))
(count (if n
(if (= n -1)
(distance-to-eol window)
n)
1)))
;; After the parameters are assembled, call the lower-level function that actually
;; uses %setcchar to create a cchar_t pointer and passes it to fn.
(funcall-make-cchar_t-ptr fn winptr ch attr_t color-pair-number count)))
(defun add-wide-char (window char &key attributes fgcolor bgcolor color-pair style y x position n)
"Add the wide (multi-byte) char to the window, then advance the cursor.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the character.
The position can also be passed in form of a two-element list.
If n is given for a char, write n chars. If n is -1, add as many chars
as will fit on the line.
If char is a complex-char, its own style overrides any style parameters.
If a style is passed, it overrides attributes and color-pair."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((attributes (if style
(getf style :attributes)
attributes))
(color-pair (cond (style
(list (getf style :fgcolor) (getf style :bgcolor)))
((or fgcolor bgcolor)
(list fgcolor bgcolor))
(t color-pair))))
(funcall-make-cchar_t #'%wadd-wch window char attributes color-pair n)))
(defun echo-wide-char (window char &key attributes fgcolor bgcolor color-pair style y x position)
"Add one wide (multi-byte) character to the window, then refresh the window.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the character.
The position can also be passed in form of a two-element list.
The only difference to add-wide-char and a subsequent refresh is a
performance gain if we know that we only need to output a single
character."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((count 1)
;; for some reason, there is a special echo function for pads.
(fn (typecase window
(pad #'%pecho-wchar)
(window #'%wecho-wchar)))
(attributes (if style
(getf style :attributes)
attributes))
(color-pair (cond (style
(list (getf style :fgcolor) (getf style :bgcolor)))
((or fgcolor bgcolor)
(list fgcolor bgcolor))
(t color-pair))))
(funcall-make-cchar_t fn window char attributes color-pair count)))
;; wide-char equivalents of the ACS chars.
;; since reading _nc_wacs doesnt work like it worked with acs_map,
;; plan B is a direct translation from ACS names to unicode code points.
;; source for the codes is ncurses/widechar/lib_wacs.c
(defparameter wide-acs-alist
;; VT100 symbols
'(( :upper-left-corner . #x250C ) ; #\BOX_DRAWINGS_LIGHT_DOWN_AND_RIGHT / 0xE2 0x94 0x8C
( :lower-left-corner . #x2514 ) ; #\BOX_DRAWINGS_LIGHT_UP_AND_RIGHT / 0xE2 0x94 0x94
( :upper-right-corner . #x2510 ) ; #\BOX_DRAWINGS_LIGHT_DOWN_AND_LEFT / 0xE2 0x94 0x90
( :lower-right-corner . #x2518 ) ; #\BOX_DRAWINGS_LIGHT_UP_AND_LEFT / 0xE2 0x94 0x98
( :tee-pointing-left . #x2524 ) ; #\BOX_DRAWINGS_LIGHT_VERTICAL_AND_LEFT / 0xE2 0x94 0xA5
( :tee-pointing-right . #x251C ) ; #\BOX_DRAWINGS_LIGHT_VERTICAL_AND_RIGHT / 0xE2 0x94 0x9C
( :tee-pointing-up . #x2534 ) ; #\BOX_DRAWINGS_LIGHT_UP_AND_HORIZONTAL / 0xE2 0x94 0xB4
( :tee-pointing-down . #x252C ) ; #\BOX_DRAWINGS_LIGHT_DOWN_AND_HORIZONTAL / 0xE2 0x94 0xAC
( :horizontal-line . #x2500 ) ; #\BOX_DRAWINGS_LIGHT_HORIZONTAL / 0xE2 0x94 0x80
( :vertical-line . #x2502 ) ; #\BOX_DRAWINGS_LIGHT_VERTICAL / 0xE2 0x94 0x82
( :crossover-plus . #x253C ) ; #\BOX_DRAWINGS_LIGHT_VERTICAL_AND_HORIZONTAL / 0xE2 0x94 0xBC
( :scan-line-1 . #x23BA ) ; #\HORIZONTAL_SCAN_LINE-1 / 0xE2 0x8E 0xBA
( :scan-line-9 . #x23BD ) ; #\HORIZONTAL_SCAN_LINE-9 / 0xE2 0x8E 0xBD
( :diamond-symbol . #x25C6 ) ; #\BLACK_DIAMOND / 0xE2 0x97 0x86
( :checker-board . #x2592 ) ; #\MEDIUM_SHADE / 0xE2 0x96 0x92
( :degree-symbol . #x00B0 ) ; #\DEGREE_SIGN / 0xC2 0xB0
( :plus-minus . #x00B1 ) ; #\PLUS-MINUS_SIGN / 0xC2 0xB1
( :bullet-symbol . #x00B7 ) ; #\MIDDLE_DOT / 0xC2 0xB7
;; Teletype 5410v1 symbols
( :arrow-pointing-left . #x2190 ) ; #\LEFTWARDS_ARROW / 0xE2 0x86 0x90
( :arrow-pointing-right . #x2192 ) ; #\RIGHTWARDS_ARROW / 0xE2 0x86 0x92
( :arrow-pointing-down . #x2193 ) ; #\DOWNWARDS_ARROW / 0xE2 0x86 0x93
( :arrow-pointing-up . #x2191 ) ; #\UPWARDS_ARROW / 0xE2 0x86 0x91
( :board . #x2592 ) ; #\MEDIUM_SHADE / 0xE2 0x96 0x92
( :lantern-symbol . #x2603 ) ; #\SNOWMAN / 0xE2 0x98 0x83
( :solid-square-block . #x25AE ) ; #\BLACK_VERTICAL_RECTANGLE / 0xE2 0x96 0xAE
;; ncurses characters
( :scan-line-3 . #x23BB ) ; #\HORIZONTAL_SCAN_LINE-3 / 0xE2 0x8E 0xBB
( :scan-line-7 . #x23BC ) ; #\HORIZONTAL_SCAN_LINE-7 / 0xE2 0x8E 0xBC
( :less-than-or-equal . #x2264 ) ; #\LESS-THAN_OR_EQUAL_TO / 0xE2 0x89 0xA4
( :greater-than-or-equal . #x2265 ) ; #\GREATER-THAN_OR_EQUAL_TO / 0xE2 0x89 0xA5
( :pi . #x03C0 ) ; #\GREEK_SMALL_LETTER_PI / 0xCF 0x80
( :not-equal . #x2260 ) ; #\NOT_EQUAL_TO / 0xE2 0x89 0xA0
( :uk-pound-sterling . #x00A3 ) ; #\POUND_SIGN / 0xC2 0xA3
;; thick line drawing characters
( :thick-upper-left-corner . #x250F ) ; #\BOX_DRAWINGS_HEAVY_DOWN_AND_RIGHT / 0xE2 0x94 0x8F
( :thick-lower-left-corner . #x2517 ) ; #\BOX_DRAWINGS_HEAVY_UP_AND_RIGHT / 0xE2 0x94 0x97
( :thick-upper-right-corner . #x2513 ) ; #\BOX_DRAWINGS_HEAVY_DOWN_AND_LEFT / 0xE2 0x94 0x93
( :thick-lower-right-corner . #x251B ) ; #\BOX_DRAWINGS_HEAVY_UP_AND_LEFT / 0xE2 0x94 0x9B
( :thick-tee-pointing-left . #x2523 ) ; #\BOX_DRAWINGS_HEAVY_VERTICAL_AND_LEFT / 0xE2 0x94 0xA3
( :thick-tee-pointing-right . #x252B ) ; #\BOX_DRAWINGS_HEAVY_VERTICAL_AND_RIGHT / 0xE2 0x94 0xAB
( :thick-tee-pointing-up . #x253B ) ; #\BOX_DRAWINGS_HEAVY_UP_AND_HORIZONTAL / 0xE2 0x94 0xBB
( :thick-tee-pointing-down . #x2533 ) ; #\BOX_DRAWINGS_HEAVY_DOWN_AND_HORIZONTAL / 0xE2 0x94 0xB3
( :thick-horizontal-line . #x2501 ) ; #\BOX_DRAWINGS_HEAVY_HORIZONTAL / 0xE2 0x94 0x81
( :thick-vertical-line . #x2503 ) ; #\BOX_DRAWINGS_HEAVY_VERTICAL / 0xE2 0x94 0x83
( :thick-crossover-plus . #x254B ) ; #\BOX_DRAWINGS_HEAVY_VERTICAL_AND_HORIZONTAL / 0xE2 0x95 0x8B
;; double-line drawing characters
( :double-upper-left-corner . #x2554 ) ; #\BOX_DRAWINGS_DOUBLE_DOWN_AND_RIGHT / 0xE2 0x95 0x94
( :double-lower-left-corner . #x255A ) ; #\BOX_DRAWINGS_DOUBLE_UP_AND_RIGHT / 0xE2 0x95 0x9A
( :double-upper-right-corner . #x2557 ) ; #\BOX_DRAWINGS_DOUBLE_DOWN_AND_LEFT / 0xE2 0x95 0x97
( :double-lower-right-corner . #x255D ) ; #\BOX_DRAWINGS_DOUBLE_UP_AND_LEFT / 0xE2 0x95 0x9D
( :double-tee-pointing-left . #x2563 ) ; #\BOX_DRAWINGS_DOUBLE_VERTICAL_AND_LEFT / 0xE2 0x95 0xA3
( :double-tee-pointing-right . #x2560 ) ; #\BOX_DRAWINGS_DOUBLE_VERTICAL_AND_RIGHT / 0xE2 0x95 0xA0
( :double-tee-pointing-up . #x2569 ) ; #\BOX_DRAWINGS_DOUBLE_UP_AND_HORIZONTAL / 0xE2 0x95 0xA9
( :double-tee-pointing-down . #x2566 ) ; #\BOX_DRAWINGS_DOUBLE_DOWN_AND_HORIZONTAL / 0xE2 0x95 0xA6
( :double-horizontal-line . #x2550 ) ; #\BOX_DRAWINGS_DOUBLE_HORIZONTAL / 0xE2 0x95 0x90
( :double-vertical-line . #x2551 ) ; #\BOX_DRAWINGS_DOUBLE_VERTICAL / 0xE2 0x95 0x91
( :double-crossover-plus . #x256C ))) ; #\BOX_DRAWINGS_DOUBLE_VERTICAL_AND_HORIZONTAL / 0xE2 0x95 0xAC
(defun wacs (char-name)
"Take a keyword symbol, return the wide unicode integer representing the ACS char."
(cdr (assoc char-name wide-acs-alist)))

230
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/addch.lisp Normal file
View file

@ -0,0 +1,230 @@
(in-package :de.anvi.croatoan)
;; (add scr #\a :y 10 :x 10)
;; (add scr "b" :y 11 :x 10)
;; (add scr #\a :y 10 :x 10 :attributes '(:underline) :color-pair '(:yellow :red))
;; (add scr "bat" :y 11 :x 10 :attributes '(:underline :bold) :color-pair '(:black :green))
;; (add scr #\a :position (list 10 10))
(defun add (window object &rest keys &key &allow-other-keys)
"Add the text object to the window, then advance the cursor.
Currently supported text objects are characters (simple and complex),
characters given by integer codes or keywords, and strings
(simple and complex).
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the object.
The position can also be passed in form of a two-element list.
If n is given for a char, write n chars. If n is -1, add as many chars
as will fit on the line.
If n is given for a string, add at most n chars from the string.
If n is -1, add as many chars from the string as will fit on the line."
(let ((fn (typecase object
((or string complex-string)
#'add-string)
((or integer keyword character complex-char)
#'add-wide-char))))
(apply fn window object keys)))
(defun distance-to-eol (window)
"Return the number of columns from the cursor position to the end of the line in the window."
(- (width window) (cadr (cursor-position window))))
(defun distance-to-bottom (window)
"Return the number of lines from the cursor position to the bottom of the window."
(- (height window) (car (cursor-position window))))
(defun add-char (window char &key attributes fgcolor bgcolor color-pair style y x position n)
"Add the narrow (single-byte) char to the window, then advance the cursor.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the character.
The position can also be passed in form of a two-element list.
If n is given for a char, write n chars. If n is -1, add as many chars
as will fit on the line.
Example: (add-char scr #\a :attributes '(:bold) :color-pair '(:red :yellow))"
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((attributes (if style
(getf style :attributes)
attributes))
(color-pair (cond (style
(list (getf style :fgcolor) (getf style :bgcolor)))
((or fgcolor bgcolor)
(list fgcolor bgcolor))
(t color-pair))))
(funcall-make-chtype #'%waddch window char attributes color-pair n)))
;; At the moment, echo is just a wrapper for echo-wide-char.
(defun echo (window char &rest keys &key &allow-other-keys)
"Add one character to the window, then advance the cursor.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the character.
The position can also be passed in form of a two-element list.
If n is given for a char, write n chars. If n is -1, add as many chars
as will fit on the line.
If char is a complex-char, its own style overrides any style parameters.
If a style is passed, it overrides attributes and color-pair."
(apply #'echo-wide-char window char keys))
(defun echo-char (window char &key attributes fgcolor bgcolor color-pair style y x position)
"Add one narrow (single-byte) character to the window, then refresh the window.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then echo the character.
The position can also be passed in form of a two-element list.
The only difference to add-char and a subsequent refresh is a
performance gain if we know that we only need to output a single
character."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((count 1)
(fn (typecase window
;; a pad is a subclass of window, therefore we have to check pad first.
(pad #'%pechochar)
(window #'%wechochar)))
(attributes (if style
(getf style :attributes)
attributes))
(color-pair (cond (style
(list (getf style :fgcolor) (getf style :bgcolor)))
((or fgcolor bgcolor)
(list fgcolor bgcolor))
(t color-pair))))
(funcall-make-chtype fn window char attributes color-pair count)))
;; just an utility function if you dont want to use (format nil "bla
;; bla ~%") to insert newlines. in C you can simply insert \n.
(defun new-line (window &optional (count 1))
"Insert count newline characters into window."
(loop repeat count do (add-char window (char-code #\newline))))
;; pointer to the global/external c acs array, acs_map[].
;; also see defcvar + get-var-pointer
(defparameter acs-map-array (foreign-symbol-pointer "acs_map"))
;; ncurses maps those standard chars at runtime to the acs characters.
;; here we use it in the function acs.
(defparameter acs-alist
;; VT100 symbols
'(( :upper-left-corner . #\l )
( :lower-left-corner . #\m )
( :upper-right-corner . #\k )
( :lower-right-corner . #\j )
( :tee-pointing-left . #\u )
( :tee-pointing-right . #\t )
( :tee-pointing-up . #\v )
( :tee-pointing-down . #\w )
( :horizontal-line . #\q )
( :vertical-line . #\x )
( :crossover-plus . #\n )
( :scan-line-1 . #\o )
( :scan-line-9 . #\s )
( :diamond-symbol . #\` )
( :checker-board . #\a )
( :degree-symbol . #\f )
( :plus-minus . #\g )
( :bullet-symbol . #\~ )
;; Teletype 5410v1 symbols
( :arrow-pointing-left . #\, )
( :arrow-pointing-right . #\+ )
( :arrow-pointing-down . #\. )
( :arrow-pointing-up . #\- )
( :board . #\h )
( :lantern-symbol . #\i )
( :solid-square-block . #\0 )
;; ncurses characters
( :scan-line-3 . #\p )
( :scan-line-7 . #\r )
( :less-than-or-equal . #\y )
( :greater-than-or-equal . #\z )
( :pi . #\{ )
( :not-equal . #\| )
( :uk-pound-sterling . #\} )
;; thick line drawing characters
( :thick-upper-left-corner . #\L )
( :thick-lower-left-corner . #\M )
( :thick-upper-right-corner . #\K )
( :thick-lower-right-corner . #\J )
( :thick-tee-pointing-left . #\U )
( :thick-tee-pointing-right . #\T )
( :thick-tee-pointing-up . #\V )
( :thick-tee-pointing-down . #\W )
( :thick-horizontal-line . #\Q )
( :thick-vertical-line . #\X )
( :thick-crossover-plus . #\N )
;; double-line drawing characters
( :double-upper-left-corner . #\C )
( :double-lower-left-corner . #\D )
( :double-upper-right-corner . #\B )
( :double-lower-right-corner . #\A )
( :double-tee-pointing-left . #\G )
( :double-tee-pointing-right . #\F )
( :double-tee-pointing-up . #\H )
( :double-tee-pointing-down . #\I )
( :double-horizontal-line . #\R )
( :double-vertical-line . #\Y )
( :double-crossover-plus . #\E )))
#|
For 64bit builds of ncurses 6.0, chtype is an unsigned int:
#if 1 && defined(_LP64)
typedef unsigned chtype;
typedef unsigned mmask_t;
#else
typedef uint32_t chtype;
typedef uint32_t mmask_t;
#endif
For 64bit builds of ncurses 5.9, chtype is an unsigned long:
#if 0 && defined(_LP64)
typedef unsigned chtype;
typedef unsigned mmask_t;
#else
typedef unsigned long chtype;
typedef unsigned long mmask_t;
#endif
acs_map[] is an chtype array:
#if 0 || NCURSES_REENTRANT
NCURSES_WRAPPED_VAR(chtype*, acs_map);
#define acs_map NCURSES_PUBLIC_VAR(acs_map())
#else
extern NCURSES_EXPORT_VAR(chtype) acs_map[];
#endif
|#
;; ACS, the alternative/extended character set for line drawing.
;; Used by functions: add-char, box and border.
;;
;; * http://www.melvilletheatre.com/articles/ncurses-extended-characters/index.html
;; * http://tldp.org/HOWTO/NCURSES-Programming-HOWTO/misc.html
;;
;; Example: (acs 'ULCORNER)
(defun acs (char-name)
"Take a symbol, return the integer representing the acs char."
(mem-aref acs-map-array 'chtype (char-code (cdr (assoc char-name acs-alist)))))

42
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/addstr.lisp Normal file
View file

@ -0,0 +1,42 @@
(in-package :de.anvi.croatoan)
(defun add-string (window string &key attributes fgcolor bgcolor color-pair style y x position n)
"Add the unrendered string to the window.
If n is given, add at most n chars from the string. If n is -1, as
many chars will be added that will fit on the line.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the object.
The position can also be passed in form of a two-element list."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((count (if n
(if (= n -1)
(- (width window) (cadr (cursor-position window)))
n)
;; we cant use length to determine the length of a complex string
;; because it is not a sequence.
(typecase string
(string (length string))
(complex-string (length (complex-char-array string)))))))
(typecase string
(string
;;(if (or attributes fgcolor bgcolor color-pair style)
;; lisp string combined with attributes and colors
(loop
repeat count
for ch across string
do (add-wide-char window ch :attributes attributes :fgcolor fgcolor :bgcolor bgcolor
:color-pair color-pair :style style)) )
;; simple lisp string, no attributes or colors
;; TODO 190826 we dont want to use this because we want to force color-set and bkgd to use separate colors
;;(if n
;; (%waddnstr (winptr window) string n)
;; (%waddstr (winptr window) string))))
(complex-string
(loop
repeat count
for ch across (complex-char-array string)
do (add-wide-char window ch))))))

501
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/attr.lisp Normal file
View file

@ -0,0 +1,501 @@
(in-package :de.anvi.croatoan)
(defparameter *ansi-color-list*
'(:black :red :green :yellow :blue :magenta :cyan :white))
;; this list should be in color.lisp, not here.
;; but attr.lisp is loaded before color.lisp.
(defparameter *xterm-color-name-list*
'(:black :maroon :green :olive :navy :purple :teal :silver
:gray :red :lime :yellow :blue :magenta :cyan :white))
(defparameter *default-color-pair* nil)
;; do not use the color alist but the two color lists, for 8 and 256 colors
;; in the 256 colors mode, only the first 16 colors are named.
;; the terminal default colors are only available when
;; the screen is initialized with :use-terminal-colors t
;; the :terminal color number is -1.
(defun color-name-to-number (color-name)
"Take a keyword denoting a color name, return the color number."
(let* ((name (cond ((eq color-name :default-fg)
(car *default-color-pair*))
((eq color-name :default-bg)
(cadr *default-color-pair*))
(t color-name)))
;; generate an alist of colors in the form ((:terminal . -1) (:black . 0) ...)
;; depending on whether we use 8 or 256 colors, we have different names for the same color numbers.
(alist (if (<= %colors 8)
(loop
for i from -1 to 7
for j in (cons :terminal *ansi-color-list*)
collect (cons j i))
(loop
for i from -1 to 15
for j in (cons :terminal *xterm-color-name-list*)
collect (cons j i))))
(number (cdr (assoc name alist))))
(if number
number
(error "color-name-to-number: color name ~A does not exist." name))))
;; address a color by:
;; integer: color number 0-255, so we can cycle through all available colors
;; keyword: it doesnt exist for all 256 colors
;; string: "#ff00ff" hex triplet in web-notation. string-length = 7, first char = #
;; a color can also be given as a list, where the first element is a keyword
;; denoting the coding scheme.
;; (:number 255)
;; (:name :black)
;; (:hex #xff00ff)
;; TODO: (:hex "#ff00ff")
;; TODO: (:rgb 255 00 255)
;; TODO: (:hsv 10 15 245)
;; TODO: naming conflict with color->number
;; after we can convert everything to a color number, add this function to
;; pair-to-number, so we can generate a color pair out of every color notation.
(defun color-to-number (color)
"Takes a color in various notations, converts that notation to the exact or most appropriate color number."
(typecase color
;; hex rgb code
;; we cant use hex codes when in 8-color ansi mode, because the 8 ansi colors
;; are only defined by names, not by rgb color contents.
(integer (hex-to-sgr color))
;; color name, for now ONLY the first 8 ansi colors and 16 web colors
;; TODO: expand to all x11 color names
(keyword (color-name-to-number color))
;; a list in the form of (:type value).
(list
(let ((type (car color))
(val (cadr color)))
(case type
;; direct input of the color number, just return it.
(:number val)
;; keyword denoting the color name
(:name (color-name-to-number color))
(:hex
(typecase val
;; hex rgb notation, for example (:hex #x00ff00)
(integer (hex-to-sgr color)))))))))
;; keys are 2 element lists of the form: (:fgcolor :bgcolor)
;; fgcolor and bgcolor are keyword symbols
;; vals are integers that represent ncurses color pairs.
;; only one color pair, 0, is predefined: (:default :default),
;; which is identical to (:white :black) if use-terminal-colors is nil.
;; if use-terminal-colors is t, it is whatever color pair the terminal
;; used before the ncurses init.
;; TODO: this also could be a hashmap
;; TODO: move this to be a screen variable, so it gets reset on every screen init
;; for now it is reset to nil on evey screen init by set-default-color-pair
(defparameter *color-pair-alist* nil)
(defun use-terminal-colors-p (screen)
(slot-value screen 'use-terminal-colors-p))
(defun (setf use-terminal-colors-p) (flag screen)
(setf (slot-value screen 'use-terminal-colors-p) flag)
(if flag
(progn
(%use-default-colors)
(setf (default-color-pair screen) (list :terminal :terminal)))
(setf (default-color-pair screen) (list :white :black))))
(defun default-color-pair (screen)
(declare (ignore screen))
*default-color-pair*)
(defun (setf default-color-pair) (color-pair screen)
"Set the colors which will comprise the default color pair 0.
The default color pair is used when no other colors are specified.
The ncurses default color pair is white on black.
If the terminal can set its own colors, they are named :terminal."
(setf *default-color-pair* color-pair)
(%assume-default-colors (color-name-to-number (car color-pair))
(color-name-to-number (cadr color-pair))))
;; called from initialize-instance :after ((scr screen)
;; test with t09a
(defun set-default-color-pair (use-terminal-colors-p)
;; reset the color pair alist on every screen init
(setf *color-pair-alist* nil)
(if use-terminal-colors-p
(progn
(%use-default-colors)
(setf *default-color-pair* (list :terminal :terminal)))
(setf *default-color-pair* (list :white :black)))
;; we cant make :white :black be pair 0, because pair 0 is ignored on several occasions
;; Example: when color-pair of a window is set to pair 1
;; adding a char with 0 is ignored and the char is added with pair 1.
;; we have to add white on black as a number bigger than 0.
(setf *color-pair-alist* (acons '(:default-fg :default-bg) 0 *color-pair-alist*)))
(defun pair-to-number (pair)
"Take a two-element list of colors, return the ncurses pair number.
The colors can be keywords or numbers -1:255.
-1 is the :terminal default color when use-terminal-colors-p is t.
If it is a new color pair, add it to ncurses, then return the new pair number.
If the pair already exists, return its pair number.
If pair is nil, return the default color number, 0.
Example:
(pair-to-number '(:white :black)) => 0"
(if pair
(let ((result (assoc pair *color-pair-alist* :test #'equal)))
(if result
;; if the entry already exists, just return the pair number.
(cdr result)
;; if the pair doesnt exist, create a new pair number
(let ((new-pair-number (list-length *color-pair-alist*)))
;; add it to the alist first.
(setf *color-pair-alist* (acons pair new-pair-number *color-pair-alist*))
;; then add it to ncurses.
(let ((fg (car pair))
(bg (cadr pair)))
(%init-pair new-pair-number (color-to-number fg) (color-to-number bg)))
;; return the newly added pair number.
new-pair-number)))
;; If pair is nil, return the default color number, 0.
0))
;; TODO: cross check with the ncurses primitives that we get the same result.
;; TODO: number-to-pair
(defun number-to-pair (number)
"Take a pair number, return a color pair in a 2 element list of keywords."
(car (rassoc number *color-pair-alist*)))
;; We cant run complete-pair here, because we dont have the window.
;; we have to run complete-pair within add-char, add-wide-char, etc.
(defun complete-default-pair (color-pair)
"Take a color pair possibly containing nil, return a pair completed from the default color pair 0."
(let ((fg (car color-pair))
(bg (cadr color-pair))
(default-pair (number-to-pair 0)))
(cond
;; when both colors are given, just return the original pair
((and color-pair fg bg) color-pair)
;; when the pair is nil or when both colors are missing
((or (null color-pair)
(and (null fg) (null bg)))
;; just return the default pair
default-pair)
;; when only the bg is missing, complete the bg
((null bg)
(list fg (cadr default-pair)))
;; when only the fg is missing, complete the fg
((null fg)
(list (car default-pair) bg)))))
(defun complete-pair (window pair)
"If either the foreground or background color is nil, complete the pair for the given window.
Return the completed pair.
Try to complete the missing colors in the following order:
1. window color pair.
2. window background character color pair.
3. ncurses default color pair 0 (white on black or the terminal default color pair)."
(let ((fg (car pair))
(bg (cadr pair)))
(cond
;; when both colors are given, just return the original pair
((and pair fg bg) pair)
;; when the pair is nil or when both colors are missing
((or (null pair)
(and (null fg) (null bg)))
(cond
((color-pair window)
;; if color pair exists, but is not complete, complete it recursively in a second step.
;; if we have fg from color pair, and a bg from background, they will be combined.
(complete-pair window (color-pair window)))
((and (background window)
(color-pair (background window)))
(complete-pair window (color-pair (background window))))
(t (number-to-pair 0))))
;; when only the bg is missing, complete the bg
((null bg)
(cond
((cadr (color-pair window))
(list fg (cadr (color-pair window))))
((and (background window)
(cadr (color-pair (background window))))
(list fg (cadr (color-pair (background window)))))
(t
(list fg (cadr (number-to-pair 0))))))
;; when only the fg is missing, complete the fg
((null fg)
(cond
((car (color-pair window))
(list (car (color-pair window)) bg))
((and (background window)
(car (color-pair (background window))))
(list (car (color-pair (background window))) bg))
(t
(list (car (number-to-pair 0)) bg)))) )))
;; TODO: use %wattr_on instead of %wattron, also for get and set
(defun add-attributes (win attributes)
"Takes a list of keywords and turns the appropriate attributes on."
(dolist (i attributes)
(setf (attributes win) (adjoin i (attributes win)))
(%wattron (winptr win) (get-bitmask i))))
(defun remove-attributes (win attributes)
"Takes a list of keywords and turns the appropriate attributes off."
(dolist (i attributes)
(setf (attributes win) (remove i (attributes win)))
(%wattroff (winptr win) (get-bitmask i))))
;; (set-attributes scr '(:bold :underline))
;; set-attributes overwrites color settings because it treats color as an attribute.
;; thats why we wont use it directly.
(defun set-attributes (winptr attributes)
"Takes a list of keywords and sets the appropriate attributes.
Overwrites any previous attribute settings including the color."
(%wattrset winptr
(apply #'logior (loop for i in attributes collect (get-bitmask i)))))
;; (%wchgat (winptr win) 9 #x00040000 0 (null-pointer))
(defun change-attributes (win n attributes &key color-pair y x position)
"Change the attributes of n chars starting at the current cursor position.
If n is -1, as many chars will be added as will fit on the line.
If the destination coordinates y and x are given, the attributes are changed
from the given point without moving the cursor position."
(when (and y x) (move win y x))
(when position (apply #'move win position))
(let ((attrs (attrs2chtype attributes))
(pair-number (pair-to-number (complete-pair win color-pair))))
(%wchgat (winptr win) n attrs pair-number (null-pointer))))
(defun set-color-pair (winptr color-pair)
"Sets the color attribute of the window only."
(%wcolor-set winptr
(pair-to-number (complete-default-pair color-pair))
(null-pointer)))
(defparameter *bitmask-alist*
;; the first four are not attributes, but bitmasks used to extract parts of the chtype.
'((:normal . #x00000000)
(:attributes . #xffffff00)
(:chartext . #x000000ff)
(:color . #x0000ff00)
;; we have 16 attributes that can be set.
;; In general, only underline, bold and reverse are widely supported by terminals.
(:standout . #x00010000)
(:underline . #x00020000)
(:reverse . #x00040000)
(:blink . #x00080000)
(:dim . #x00100000)
(:bold . #x00200000)
(:altcharset . #x00400000)
(:invis . #x00800000)
(:protect . #x01000000)
(:horizontal . #x02000000)
(:left . #x04000000)
(:low . #x08000000)
(:right . #x10000000)
(:top . #x20000000)
(:vertical . #x40000000)
(:italic . #x80000000)))
;; TODO: signal an error if passed an invalid attribute.
(defun get-bitmask (attribute)
"Returns an ncurses attr/chtype representing the attribute keyword."
(cdr (assoc attribute *bitmask-alist*)))
(defparameter *valid-attributes*
'(:standout
:underline
:reverse
:blink
:dim
:bold
:altcharset
:invis
:protect
:horizontal
:left
:low
:right
:top
:vertical
:italic))
(defun chtype2attrs (ch)
"Take a chtype, return a list of used attribute keywords."
(loop
for i in *valid-attributes*
if (logtest ch (get-bitmask i)) collect i))
;; used in: make-chtype, change-attributes
(defun attrs2chtype (attrs)
"Take a list of attribute keywords, return a chtype with the attribute bits set."
(if attrs
;; the attribute bitmasks already are bit-shifted to the correct position in the chtype
;; we just need to OR them all together
(apply #'logior (mapcar #'get-bitmask attrs))
;; if the attribute list is nil, logior returns 0.
;; but to emphasize intent, we explicitely return 0 if the attribute list is nil.
0))
(defun colors2chtype (color-pair)
"Take a list of a color pair, return a chtype with the color attribute set."
(if color-pair
;; convert the pair to an integer, then bit shift it by 8
;; right shift by 8 to get the color bits at their proper place in a chtype.
;; you cannot simply logior the pair number because that would overwrite the char.
(ash (pair-to-number color-pair) 8)
0))
;; usage: c2x, extract wide char, everywhere where number-to-pair is used.
;; first get the color attribute bits by log-AND-ing them with the ch.
;; then right shift them by 8 to extract the color pair short int from them.
;; then get the color pair (:white :black) associated with that number.
(defun chtype2colors (ch)
"Take a chtype or attr_t integer, return a list of two keywords denoting a color pair."
(number-to-pair (ash (logand ch (get-bitmask :color)) -8)))
(defun char2chtype (char)
"Take a character in different forms, return a chtype containing that character."
(if char
(typecase char
;; if the char is already an integer from char-code.
(integer char)
;; alternative chars are given as keywords
;; we use acs only when we produce chtypes, for cchar_t, we need wacs.
(keyword (acs char))
;; if it is a lisp char, convert it to an integer first
(character (char-code char))
;; if char is any other type, we dont handle it for now.
(otherwise (error "char2chtype: char is not integer, keyword or character.")))
0))
;;; ------------------------------------------------------------------
(defun make-chtype (char attributes color-pair)
"Assemble a chtype out of a char, attributes and a color-pair.
char can be a lisp character, an ACS keyword, or an integer code point.
attributes should be a list of valid attribute keywords.
color-pair should be a list of a foreground and background color keyword.
attributes and color-pair can be nil.
If char is a complex char, and the attributes and color-pair are passed,
they override the attributes and the color-of the complex char."
(typecase char
;; x2c itself calls make-chtype
(complex-char (xchar2chtype char))
;; we first convert all three parameters to separate integers,
;; then OR them together to create the chtype.
(otherwise (logior (char2chtype char)
(attrs2chtype attributes)
(colors2chtype color-pair)))))
;; factor out count calculation and complete-pair
(defun funcall-make-chtype (fn window char attributes color-pair n)
"Assemble a chtype out of a char, attributes and a color-pair.
Apply low-level ncurses function fn count times to window and chtype.
chtype is a 32-bit integer representing a non-wide complex-char in ncurses.
char can be a lisp character, an ACS keyword, an integer code point or
a complex char.
attributes should be a list of valid attribute keywords.
color-pair should be a list of a foreground and background color keyword.
attributes and color-pair can be nil.
If char is a complex char, attributes and color-pair are ignored."
(let ((winptr (winptr window))
(count (if n
(if (= n -1)
(distance-to-eol window)
n)
1))
(chtype (make-chtype char attributes (complete-pair window color-pair))))
(case count
(0 nil)
(1 (funcall fn winptr chtype))
(otherwise (dotimes (i count)
(funcall fn winptr chtype))))))
;; Example: (xchar2chtype (chtype2xchar 2490466)) => 2490466
(defun xchar2chtype (ch)
"Convert a croatoan complex char to an integral ncurses chtype."
(make-chtype (simple-char ch)
(attributes ch)
(color-pair ch)))
(defun chtype2xchar (ch)
"Converts a ncurses chtype to croatoan complex-char."
(make-instance 'complex-char
:simple-char (code-char (logand ch (get-bitmask :chartext)))
:attributes (loop for i in *valid-attributes*
if (logtest ch (get-bitmask i)) collect i)
;; first get the color attribute bits by log-AND-ing them with ch.
;; then right shift them by 8 to extract the color int from them.
;; then get the color pair (:white :black) associated with that number.
:color-pair (number-to-pair (ash (logand ch (get-bitmask :color)) -8))))
(defgeneric convert-char (char result-type)
(:documentation "Take a char and convert it to a char of result-type."))
;; The lisp class representing chtype is complex-char.
(defmethod convert-char ((char complex-char) result-type)
(case result-type
(:simple-char (simple-char char))
(:chtype (xchar2chtype char))))
;; Lisps character object is here called "simple-char".
(defmethod convert-char ((char character) result-type)
(case result-type
(:complex-char (make-instance 'complex-char :simple-char char :attributes nil))
(:chtype (char-code char))))
;; chtype is a ncurses unsigned long, an integer.
(defmethod convert-char ((char integer) result-type)
(case result-type
(:simple-char (code-char (logand char (get-bitmask :chartext))))
(:complex-char (chtype2xchar char))))
;;; TODOs
;; todo: convert-char -> convert
;; [ ] add type asserts.
;; what is an attr_t? get all ncurses types definitions.
;; make it clear which routines use xchars and which use chtypes.
;; make all user visible apis use xchars and only internally convert to chtypes.
;; functions to manipulate attributes and colors of xchars.
;; the char part of an xchar should not be changeable.

11
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/beep.lisp Normal file
View file

@ -0,0 +1,11 @@
(in-package :de.anvi.croatoan)
(defun alert (&optional (type :beep))
(case type
(:beep (%beep))
(:flash (%flash))
(otherwise (error "Available alert types: :beep :flash"))))
;;; TODOs
;; [ ] Return values, errors.

32
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/bkgd.lisp Normal file
View file

@ -0,0 +1,32 @@
(in-package :de.anvi.croatoan)
;; bkgd applies to every cell in the window.
;; bkgdset applies only to new chars inserted after the call to bkgdset.
;; i.e. with bkgd we manipulate the existing text, with bkgdset the new text.
;; the attribute part of the background char is combined with any chars added.
;; because of that, we cant use alternate chars as background chars, since
;; :altcharset is an attribute.
(defun set-background-char (winptr xchar &optional (apply t))
"Set a complex single-byte character as the background of a window.
The attribute part of the background character is combined with
simple characters in the window.
If apply is t, the background setting is immediately applied to all cells
in the window.
Otherwise, it is applied only to newly added simple characters."
(let ((chtype (xchar2chtype xchar)))
(if apply
;; the background char is applied to every cell in the window by default.
(%wbkgd winptr chtype)
;; if apply is nil, the background is combined only with new characters.
(%wbkgdset winptr chtype))))
(defun get-background-char (window)
"Return the complex char that is the background character of the window."
(let* ((winptr (winptr window))
(chtype (%getbkgd winptr)))
(chtype2xchar chtype)))

51
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/bkgrnd.lisp Normal file
View file

@ -0,0 +1,51 @@
(in-package :de.anvi.croatoan)
;; bkgrnd applies to every char in the window.
;; bkgrndset applies only to new chars inserted after the call to bkgdset.
;; i.e. with bkgrnd we manipulate the existing text, with bkgrndset the new text.
;; the attribute part of the background char is combined with any chars added.
;; because of that, we cant use alternate chars as background chars, since
;; :altcharset is an attribute.
(defun set-background-cchar_t (window char &optional (apply t))
"Set a wide complex character as the background of a window.
The attribute part of the background character is combined with
simple characters added to the window.
If apply is t, the background setting is immediately applied to all cells
in the window.
Otherwise, it is applied only to newly added simple characters."
(let ((fn (if apply #'%wbkgrnd #'%wbkgrndset))
(count 1))
(if char
(funcall-make-cchar_t fn window char nil nil count)
;; setting char to nil means to unset the background
;; unset the background means set space as char and the default color pair 0
(funcall-make-cchar_t fn window #\space nil (number-to-pair 0) count))))
;; used in: get-background-cchar_t, extract-wide-char
(defun funcall-get-cchar_t (fn window)
"Call function fn to read a cchar_t from window and return it as a wide complex char."
(with-foreign-object (ptr '(:struct cchar_t))
;; read a struct cchar_t into the space allocated with ptr
(funcall fn (winptr window) ptr)
;; the slot cchar-chars is a a pointer to the wchar_t array.
(let* ((char (mem-aref (foreign-slot-pointer ptr '(:struct cchar_t) 'cchar-chars) 'wchar_t 0))
;; ABI6
(col (foreign-slot-value ptr '(:struct cchar_t) 'cchar-colors))
(attr (foreign-slot-value ptr '(:struct cchar_t) 'cchar-attr)))
(make-instance 'complex-char
:simple-char (code-char char)
:attributes (chtype2attrs attr)
;; ABI6
;;:color-pair (number->pair col)
;; ABI5
;; the color pair is not placed into the cchar_t slot, but ORed into the attribute int.
:color-pair (chtype2colors attr)))))
(defun get-background-cchar_t (window)
"Return the wide complex char that is the background character of the window."
(funcall-get-cchar_t #'%wgetbkgrnd window))

23
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/border.lisp Normal file
View file

@ -0,0 +1,23 @@
(in-package :de.anvi.croatoan)
;; (box win hline vline) = (draw-border win vline vline hline hline nil nil nil nil)
(defun box (window &optional (hline-char 0) (vline-char 0))
"Draw a border around the window.
If any parameter is nil or zero, the default ACS char will be used."
(let ((winptr (winptr window)))
(%box winptr hline-char vline-char)))
(defun draw-border (window &key left right top bottom ;; lines
top-left top-right bottom-left bottom-right) ;; corners
"Draw a border around the window using single-byte line-drawing characters.
If no border chars are given, the default ncurses ACS chars will be used."
(let ((winptr (winptr window)))
(apply #'%wborder
winptr
;; if the argument is not nil, convert it to chtype first, the pass it to wborder.
;; if the argument is nil, pass 0 to wborder, then the default ACS char will be used.
(mapcar #'(lambda (i) (if i (make-chtype i nil nil) 0))
(list left right top bottom ;; lines
top-left top-right bottom-left bottom-right))))) ;; corners

39
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/border_set.lisp Normal file
View file

@ -0,0 +1,39 @@
(in-package :de.anvi.croatoan)
(defun draw-wide-border (window &key left right top bottom
top-left top-right bottom-left bottom-right)
"Draw a border around the window using (wide) unicode line-drawing characters.
If no border chars are given, the default ncurses WACS chars will be used."
(with-foreign-objects ((ls '(:struct cchar_t))
(rs '(:struct cchar_t))
(ts '(:struct cchar_t))
(bs '(:struct cchar_t))
(tl '(:struct cchar_t))
(tr '(:struct cchar_t))
(bl '(:struct cchar_t))
(br '(:struct cchar_t))
(wch 'wchar_t 5))
(apply #'%wborder-set
(winptr window)
;; take a list of (wide) character codes and empty cchar_t pointers, return a list of cchar_t pointers or null pointers.
(mapcar #'(lambda (char ptr)
(if char
;; if nil, then null-pointer, then the default wacs will be used
;; if not nil, pointer to cchar_t
(progn
;; blank the wch array in the struct
(dotimes (ii 5) (setf (mem-aref wch 'wchar_t ii) 0))
;; copy the char code to the wch array
(setf (mem-aref wch 'wchar_t) char)
;; assemble the cchar_t using %setcchar
(%setcchar ptr wch 0 0 (null-pointer))
;; return the pointer to the cchar_t
ptr)
;; if the char is not passed, return a null-pointer.
(null-pointer)))
;; list of passed character codes
(list left right top bottom top-left top-right bottom-left bottom-right)
;; list of pointers to allocated cchar_t structs
(list ls rs ts bs tl tr bl br)))))

1564
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/classes.lisp Normal file
View file

File diff suppressed because it is too large Load diff

27
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/clear.lisp Normal file
View file

@ -0,0 +1,27 @@
(in-package :de.anvi.croatoan)
;; (clear scr :redraw t)
;; (clear scr :target :whole-screen :redraw t)
;; (clear scr :target :end-of-line)
;; (clear scr :target :bottom)
(defgeneric clear (object &key))
(defmethod clear ((window window) &key redraw (target :whole-window))
"Clear the window by overwriting it with blanks.
If the keyword redraw is t, first copy blanks to every position in the
window, then set the clear-redraw-flag to have the window redrawn from
scratch on the next refresh.
If target is :end-of-line, clear the window from the cursor to the end
of the current line.
If target is :bottom, clear the window from the cursor to the end of
the current line and all lines below."
(let ((winptr (winptr window)))
(case target
(:whole-window (if redraw (%wclear winptr) (%werase winptr)))
(:end-of-line (%wclrtoeol winptr))
(:bottom (%wclrtobot winptr)))))

160
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/color.lisp Normal file
View file

@ -0,0 +1,160 @@
(in-package :de.anvi.croatoan)
;; 1000 -> 255 (ff)
(defun color-1k-to-8bit (integer)
"Convert the ncurses color intensity 0-1000 to the 8bit range 0-255."
(values (round (* integer 0.255))))
;; 255 (ff) -> 1000
(defun color-8bit-to-1k (integer)
"Convert the 8bit range 0-255 to the ncurses color intensity 0-1000."
(values (round (* integer (/ 1 0.255)))))
;; https://www.w3schools.com/colors/colors_rgb.asp
;; 255 255 255 -> ffffff
;; the hex triplet is a 6 digit, 3 byte (24 bit) hexadecimal number
;; 255 192 203 :pink
(defun rgb-to-hex (rgb-list)
"Take a list of three 8bit (0-255) RGB values, return a 24bit integer (RGB hex triplet)."
(let ((r (nth 0 rgb-list))
(g (nth 1 rgb-list))
(b (nth 2 rgb-list)))
(logior (ash r 16)
(ash g 8)
(ash b 0))))
;; test: (format t "~x" (rgb-to-hex (list 255 255 0)))
;; (hex-to-rgb #xffffff) => (255 255 255)
(defun hex-to-rgb (hex)
"Take a 24bit integer (RGB hex triplet), return a list of three 8bit (0-255) RGB values."
(let ((r (ldb (byte 8 16) hex))
(g (ldb (byte 8 8) hex))
(b (ldb (byte 8 0) hex)))
(list r g b)))
;;(defun hex-to-string (hex)
;; (format nil "~6,'0x" hex))
;; SGR = select graphc rendition, vt100 attribute sequences
;; xterm sources:
;; https://github.com/joejulian/xterm/blob/master/256colres.pl
;; https://github.com/joejulian/xterm/blob/master/256colres.h
;; https://gist.github.com/clairvy/566623#file-256colors2-pl
;; scale rgb values from 0-255 down to 0-5, corresponding to colors in the xterm 6x6x6 RGB cube.
(defun rgb-to-rgb6 (rgb-list)
"Take a list of three RGB integers 0-255, return a list of three RGB integers 0-5."
(mapcar (lambda (x)
(if (< x 55)
0
(floor (/ (- x 55) 40))))
rgb-list))
;; scale rgb values from 0-5 to 0-255, from the xterm 6x6x6 RGB color cube to 3x8bit=24bit.
(defun rgb6-to-rgb (rgb6-list)
"Take a list of three RGB integers 0-5, return a list of three RGB integers 0-255 of the xterm color palette."
(mapcar (lambda (x) (if (> x 0)
(+ 55 (* 40 x))
0))
rgb6-list))
(defun rgb6-to-sgr (rgb6-list)
"Take a list of three RGB integers 0-5, return an 8bit SGR color code 16-231."
(let ((r (nth 0 rgb6-list))
(g (nth 1 rgb6-list))
(b (nth 2 rgb6-list)))
(+ (* r 36)
(* g 6)
(* b 1)
16)))
;; only returns values from the color cube, not from the grayscale ramp 232-255.
(defun sgr-to-rgb6 (sgr)
"Take a 8bit SGR color code 16-231, return a list of three RGB integers 0-5."
(let* ((rgb (- sgr 16))
(r (floor rgb 36))
(r-rem (- rgb (* 36 r)))
(g (floor r-rem 6))
(b (- r-rem (* 6 g))))
(list r g b)))
;; the rgb values of the first 8 ansi colors arent defined, they only have names.
;; the first 16 colors of the 256-color palette have names ("web colors") and rgb values.
;; https://en.wikipedia.org/wiki/Web_colors
;; TODO: this list is also defined in attr.lisp, but it should only be here
;;(defparameter *xterm-color-name-list*
;; '(:black :maroon :green :olive :navy :purple :teal :silver
;; :gray :red :lime :yellow :blue :magenta :cyan :white))
(defparameter *xterm-color-hex-list*
'(#x000000 ;black
#x800000 ;web maroon
#x008000 ;web green
#x808000 ;olive
#x000080 ;navy blue
#x800080 ;web purple
#x008080 ;teal
#xc0c0c0 ;silver
#x808080 ;web gray
#xff0000 ;red
#x00ff00 ;lime, x11: green
#xffff00 ;yellow
#x0000ff ;blue
#xff00ff ;magenta, x11: fuchsia
#x00ffff ;cyan, x11: aqua
#xffffff)) ;white
(defun gray-to-rgb (sgr)
"Take a sgr gray color number 232-255, return a list of three RGB integers 0-255."
(let ((val (+ 8 (* 10 (- sgr 232)))))
(list val val val)))
(defun closest-gray (rgb)
"Take an integer 0-255 denoting a gray color intensity, return the closest gray from the xterm palette."
(let* ((allowed-gray-values (loop for i from 0 to 23 collect (+ 8 (* 10 i))))
(delta-list (mapcar (lambda (x) (abs (- rgb x))) allowed-gray-values))
(delta-min (apply #'min delta-list))
(pos (position delta-min delta-list)))
(+ 232 pos)))
;;(nth pos allowed-gray-values)))
;; otherwise return the closest short-rgb color.
;; TODO: we do not want the approximated and the exact color returned by the same function.
;; we need to check whether the hex is in the palette and return that
;; and if it is NOT in the palette, then either init a new color or return the closest color
;; from the palette.
(defun hex-to-sgr (hex)
"Takes a RGB hex triplet, returns the exact or most appropriate SGR color code 0-255."
(let ((rgb-list (hex-to-rgb hex)))
;; TODO: check whether we use 8 or 256 colors, limit the hex codes to the first 8 if necessary.
(cond
;; is the hex value one of the 16 basic ansi colors?
((member hex *xterm-color-hex-list*)
(position hex *xterm-color-hex-list*))
;; if all three rgb values are equal, return the closest shade of gray.
;; TODO: what if they are almost equal, for example (243 242 244)?
((apply #'= rgb-list)
(closest-gray (car rgb-list)))
;; if they arent equal, return the closest value from the 6x6x6 rgb cube.
(t (rgb6-to-sgr (rgb-to-rgb6 rgb-list))))))
;; handles all three xterm-256color color spaces
;; we need this to list the rgb values of all 256 xterm colors to compare them to the x11 color list.
;; TODO: use this to make a list containing all 256 SGR hex codes.
(defun sgr-to-hex (sgr)
"Take a SGR color code 0-255, return a 24bit hex triplet."
(cond
;; 8 ansi colors (8 normal and 8 bright or bold) 0-15
;; just return the hex integer from the list
((< sgr 16)
;;(cdr (assoc sgr *ansi-color-sgr-hex-alist*)))
(nth sgr *xterm-color-hex-list*))
;; 216 colors from a 6x6x6 RGB color cube, 16-231
((< sgr 232)
(rgb-to-hex (rgb6-to-rgb (sgr-to-rgb6 sgr))))
;; 24 gray colors without black and white, which are contained in both 1. and 2.
((< sgr 256)
(rgb-to-hex (gray-to-rgb sgr)))))

297
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/croatoan.lisp Normal file
View file

@ -0,0 +1,297 @@
(in-package :de.anvi.croatoan)
;;; Define all macros here centrally.
(defmacro with-screen ((screen &key
(bind-debugger-hook t)
(input-buffering nil)
(process-control-chars t)
(enable-newline-translation t)
(input-blocking t)
(input-echoing t)
(enable-function-keys t)
(enable-scrolling nil)
(insert-mode nil)
(enable-colors t)
(use-terminal-colors nil)
(cursor-visible t)
(stacked nil)
(fgcolor nil)
(bgcolor nil)
(color-pair nil)
(background nil))
&body body)
"Create a screen, evaluate the forms in the body, then cleanly close the screen.
Pass any arguments besides BIND-DEBUGGER-HOOK to the initialisation of the
screen object. The screen is cleared immediately after initialisation.
This macro will bind *DEBUGGER-HOOK* so that END-SCREEN gets called before the
condition is printed. This will interfere with SWANK as it also binds *DEBUGGER-HOOK*.
To prevent WITH-SCREEN from binding *DEBUGGER-HOOK*, set BIND-DEBUGGER-HOOK to NIL.
This macro is the main entry point for writing ncurses programs with the croatoan
library. Do not run more than one screen at the same time."
`(unwind-protect
(let ((,screen (make-instance 'screen
:input-buffering ,input-buffering
:process-control-chars ,process-control-chars
:enable-newline-translation ,enable-newline-translation
:input-blocking ,input-blocking
:input-echoing ,input-echoing
:enable-function-keys ,enable-function-keys
:enable-scrolling ,enable-scrolling
:insert-mode ,insert-mode
:enable-colors ,enable-colors
:use-terminal-colors ,use-terminal-colors
:cursor-visible ,cursor-visible
:stacked ,stacked
:fgcolor ,fgcolor
:bgcolor ,bgcolor
:color-pair ,color-pair
:background ,background))
;; when an error is signaled and not handled, cleanly end ncurses, print the condition text
;; into the repl and get out of the debugger into the repl.
;; the debugger is annoying with ncurses apps.
;; add (abort) to automatically get out of the debugger.
;; this binding is added by default. call with-screen with :bind-debugger-hook nil to remove.
,@(if bind-debugger-hook
'((*debugger-hook* #'(lambda (c h)
(declare (ignore h))
(end-screen)
(print c))))
nil))
;; clear the display when starting up.
(clear ,screen)
,@body)
;; cleanly exit ncurses whatever happens.
(end-screen)))
(defmacro with-window ((win &rest options) &body body)
"Create a window, evaluate the forms in the body, then cleanly close the window.
Pass any arguments to the initialisation of the window object.
Example:
(with-window (win :input-echoing t
body)"
`(let ((,win (make-instance 'window ,@options)))
(unwind-protect
(progn
,@body)
(close ,win))))
;; see similar macro cffi:with-foreign-objects.
(defmacro with-windows (bindings &body body)
"Create one or more windows, evaluate the forms in the body, then cleanly close the windows.
Pass any arguments to the initialisation of the window objects.
Example:
(with-windows ((win1 :input-echoing t)
(win2 :input-echoing t))
body)"
(if bindings
;; execute the bindings recursively
`(with-window ,(car bindings)
;; the cdr is the body
(with-windows ,(cdr bindings)
,@body))
;; finally, execute the body.
`(progn
,@body)))
(defmacro event-case ((window event &optional mouse-y mouse-x) &body body)
"Window event loop, events are handled by an implicit case form.
For now, it is limited to events generated in a single window. So events
from multiple windows have to be handled separately.
In order for event handling to work, input-buffering has to be nil.
Several control character events can only be handled when
process-control-chars is also nil.
If input-blocking is nil, we can handle the (nil) event, i.e. what
happens between key presses.
If input-blocking is t, the (nil) event is never returned.
The main window event loop name is hard coded to event-case to be
used with return-from.
Instead of ((nil) nil), which eats 100% CPU, use input-blocking t."
(if (and mouse-y mouse-x)
`(loop :named event-case do
(multiple-value-bind (,event ,mouse-y ,mouse-x)
;; depending on which version of ncurses is loaded, decide which event reader to use.
#+(or sb-unicode unicode openmcl-unicode-strings) (get-wide-event ,window)
#-(or sb-unicode unicode openmcl-unicode-strings) (get-event ,window)
;;(print (list ,event mouse-y mouse-x) ,window)
(when (null ,event)
;; process the contents of the job queue (ncurses access from other threads)
(process))
(case ,event
,@body)))
`(loop :named event-case do
;; depending on which version of ncurses is loaded, decide which event reader to use.
(let ((,event #+(or sb-unicode unicode openmcl-unicode-strings) (get-wide-event ,window)
#-(or sb-unicode unicode openmcl-unicode-strings) (get-event ,window)))
(when (null ,event)
;; process the contents of the job queue (ncurses access from other threads)
(process))
(case ,event
,@body)))))
(defun bind (object event handler)
"Bind the handler function to the event in the bindings alist of the object.
The handlers will be called by the run-event-loop when keyboard or mouse events occur.
The handler functions have two mandatory arguments, window and event.
For every event-loop, at least an event to exit the event loop should be assigned,
by associating it with the predefined function exit-event-loop.
If a handler for the default event t is defined, it will handle all events for which
no specific event handler has been defined.
If input-blocking of the window is set to nil, a handler for the nil event
can be defined, which will be called at a specified frame-rate between keypresses.
Here the main application state can be updated.
Alternatively, to achieve the same effect, input-blocking can be set to a specific
delay in miliseconds.
Example use: (bind scr #\q (lambda (win event) (throw 'event-loop :quit)))"
(setf (bindings object)
(acons event handler (bindings object))))
(defun unbind (object event)
"Remove the event and the handler function from object's bindings alist."
(setf (slot-value object 'bindings)
(remove event (slot-value object 'bindings) :key #'car)))
(defparameter *keymaps* nil "An alist of available keymaps.")
(defun define-keymap (name plist)
"Register a keymap given by a name and a plist of keys and functions."
(let ((keymap (make-instance 'keymap :bindings-plist plist)))
(setf *keymaps* (acons name keymap *keymaps*))))
(defun find-keymap (keymap-name)
"Return a keymap given by its name from the global keymap alist."
(cdr (assoc keymap-name *keymaps*)))
;; source: alexandria
(defun plist2alist (plist)
"Take a plist in the form (k1 v1 k2 v2 ...), return an alist ((k1 . v1) (k2 . v2) ...)"
(let (alist)
(do ((lst plist (cddr lst)))
((endp lst) (nreverse alist))
(push (cons (car lst) (cadr lst)) alist))))
(defun get-event-handler (object event)
"Take an object and an event, return the object's handler for that event.
The key bindings alist is stored in the bindings slot of the object.
If no handler is defined for the event, the default event handler t is tried.
If not even a default handler is defined, the event is ignored.
If input-blocking is nil, we receive nil events in case no real events occur.
In that case, the handler for the nil event is returned, if defined.
The event pairs are added by the bind function as conses: (event . #'handler).
An event should be bound to the pre-defined function exit-event-loop."
(flet ((ev (event)
(let ((keymap (typecase (keymap object)
(keymap (keymap object))
(symbol (find-keymap (keymap object))))))
;; object-local bindings override the external keymap
;; an event is checked in the bindings first, then in the external keymap.
(if (bindings object)
(if (assoc event (bindings object))
(assoc event (bindings object))
(if (and keymap (bindings keymap))
(assoc event (bindings keymap))
nil))
;; if there are no local bindings, check the external keymap
(if (and keymap (bindings keymap))
(assoc event (bindings keymap))
nil)))))
(cond
;; Event occured and event handler is defined.
((and event (ev event)) (cdr (ev event)))
;; Event occured and a default event handler is defined.
;; If not even the default handler is defined, the event is ignored.
((and event (ev t)) (cdr (ev t)))
;; If no event occured and the idle handler is defined.
;; The event is only nil when input input-blocking is nil.
((and (null event) (ev nil)) (cdr (ev nil)))
;; If no event occured and the idle handler is not defined.
(t nil))))
(defun run-event-loop (object &rest args)
"Read events from the window, then call predefined event handler functions on the events.
The handlers can be added by the bind function, or by directly setting a predefined keymap
to the window's bindings slot.
Args is one or more additional arguments passed to the handlers.
Provide a non-local exit point so we can exit the loop from an event handler.
One of the events must provide a way to exit the event loop by throwing 'event-loop.
The function exit-event-loop is pre-defined to perform this non-local exit."
(catch object
(loop
(let* ((window (typecase object
(form-window (sub-window object))
;; if the object is a window
(window object)
;; if the object isnt a window, it should have an associated window.
(otherwise (window object))))
(event (get-wide-event window)))
(handle-event object event args)
;; process the contents of the job queue (ncurses access from other threads)
(process)
;; should a frame rate be a property of the window or of the object?
(when (and (null event) (frame-rate window))
(sleep (/ 1.0 (frame-rate window)))) ))))
(defgeneric handle-event (object event args)
;; the default method applies to window, field, button, menu.
(:method (object event args)
"Default method for all objects without a specialized method."
(let ((handler (get-event-handler object event)))
(when handler
;; if args is nil, apply will call the handler with just object and event
;; this means that if we dont need args, we can define most handlers as two-argument functions.
(apply handler object event args)))))
(defmethod handle-event ((form form) event args)
"If a form can't handle an event, let the current form element try to handle it."
(let ((handler (get-event-handler form event)))
(if handler
(apply handler form event args)
(handle-event (current-element form) event args))))
(defun exit-event-loop (object event &rest args)
"Associate this function with an event to exit the event loop."
(declare (ignore win event args))
(throw object :exit-event-loop))
(defmacro save-excursion (window &body body)
"After executing body, return the cursor in window to its initial position."
(let ((pos (gensym)))
`(let ((,pos (cursor-position ,window)))
,@body
(move ,window (car ,pos) (cadr ,pos)))))

30
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/default_colors.lisp Normal file
View file

@ -0,0 +1,30 @@
(in-package :croatoan)
;; default_colors
;; use terminal's default colors
;; http://invisible-island.net/ncurses/man/default_colors.3x.html
;;; C prototypes
;; int use_default_colors(void);
;; int assume_default_colors(int fg, int bg);
;;; Low-level C functions
(defcfun ("use_default_colors" %use-default-colors) :int)
(defcfun ("assume_default_colors" %assume-default-colors) :int (fg :int) (bg :int))
;;; High-level Lisp wrappers
(defun use-default-colors (flag)
"Assign the terminal default colors to the color number -1."
(when flag
(%use-default-colors)))
(defun assume-default-colors (fg bg)
"Modify the default color pair 0 to use the color numbers fg and bg.
Ncurses otherwise will use white on black."
(%assume-default-colors fg bg))
;;; NOTICE

24
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/define_key.lisp Normal file
View file

@ -0,0 +1,24 @@
(in-package :croatoan)
;; define_key
;; define a keycode
;; http://invisible-island.net/ncurses/man/define_key.3x.html
;;; C prototypes
;; int define_key(const char *definition, int keycode);
;;; Low-level C functions
(defcfun ("define_key" %define-key) :int (definition :string) (keycode :int))
;;; High-level Lisp wrappers
(defun define-key (definition code)
"Define a new keycode with its definition string.
If the string is empty, or the code zero or negative, the existing
definition is removed."
(%define-key definition code))
;;; TODOs

14
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/delch.lisp Normal file
View file

@ -0,0 +1,14 @@
(in-package :de.anvi.croatoan)
(defun delete-char (window &key y x)
"Delete the character under the cursor.
All characters to the right of the cursor on the same line are moved
to the left one position and the last character on the line is filled
with a blank. The cursor position does not change after moving
to (y,x), if specified."
(let ((winptr (winptr window)))
(cond ((and y x)
(%mvwdelch winptr y x))
(t
(%wdelch winptr)))))

18
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/deleteln.lisp Normal file
View file

@ -0,0 +1,18 @@
(in-package :de.anvi.croatoan)
(defun delete-line (window &key (n 1))
"Delete n lines starting with the one under the cursor.
The remaining lines are moved up. The bottom n lines are cleared.
The current cursor position does not change."
(%winsdelln (winptr window) (- n)))
(defun insert-line (window &key (n 1))
"Insert n lines above the current line.
The current line and the lines below are moved down. The n bottom
lines are lost.
The current cursor position does not change."
(%winsdelln (winptr window) n))

19
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/extend.lisp Normal file
View file

@ -0,0 +1,19 @@
(in-package :croatoan)
;;; extend
;;; miscellaneous curses extensions
;;; http://invisible-island.net/ncurses/man/curs_extend.3x.html
;;; C prototypes
;; const char * curses_version(void);
;; int use_extended_names(bool enable);
;;; Low-level C functions
(defcfun ("curses_version" %curses-version) :string)
(defcfun ("use_extended_names" %use-extended-names) :int (enable :boolean))
;;; High-level Lisp wrappers
;;; NOTES

484
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/form.lisp Normal file
View file

@ -0,0 +1,484 @@
(in-package :de.anvi.croatoan)
;; form
;; curses extension for programming forms
;; https://invisible-island.net/ncurses/man/form.3x.html
(defun remove-nth (n list)
"Remove element at nth place from the list, decreasing the length of the list.
Example: (remove-nth 3 '(a b c d e)) => (A B C E)"
(declare
(type (integer 0) n)
(type list list))
(assert (>= n 0))
(assert (> (length list) n))
(if (or (zerop n) (null list))
(cdr list)
(cons (car list) (remove-nth (1- n) (cdr list)))))
(defun insert-nth (n element list)
"Insert element into list at nth place, increasing the length of the list.
Example: (insert-nth 3 'x '(a b c d e)) => (A B C X D E)"
(declare
(type (integer 0) n)
(type list list))
(assert (>= n 0))
(assert (>= (length list) n))
(if (or (zerop n) (null list))
(cons element list)
(cons (car list) (insert-nth (1- n) element (cdr list)))))
(defun replace-nth (n element list)
"Replaces element of list at nth place, not increasing the length of the list.
Example: (replace-nth 3 'x '(a b c d e)) => (A B C X E)"
(declare
(type (integer 0) n)
(type list list))
(assert (>= n 0))
(assert (>= (length list) n))
(if (or (zerop n) (null list))
(cons element (cdr list))
(cons (car list) (replace-nth (1- n) element (cdr list)))))
(defun find-element (form element-name &key (test #'eql) (key #'name))
"Return from the given form the element given by its name.
The name should be a keyword, symbol or integer, the default test is eql.
If the name is a string, equal should be used as the test.
Instead of the name, another key can be provided to identify the element."
(find element-name (elements form) :test test :key key))
;; this is the only place we set the background style for the field
;; TODO: how to access the default fg and bg of a form,
;; if the field is not part of a form? by having a form slot in the field.
(defmethod clear ((field field) &key)
"Clear the field by overwriting it with the background char.
The default background char is #\space."
(with-accessors ((pos location) (width width) (selected selectedp) (win window) (style style)) field
(let* ((bg-style (if selected (getf style :selected-background) (getf style :background)))
(bg-char (if (getf bg-style :simple-char) (getf bg-style :simple-char) #\space)))
(setf (cursor-position win) pos)
(add win bg-char :style bg-style :n width)
(setf (cursor-position win) pos))))
(defgeneric update-cursor-position (object)
(:documentation "Update the cursor position of the element of a form.")
(:method (object)
"The default method puts the cursor at the start position of the element."
(setf (cursor-position (window object)) (location object))
(refresh (window object))))
;; when the form element is an embedded selection menu or checklist
;; will not work for menu-windows, which arent yet embedded in forms.
;; we need a separate update-cursor-position for menu-window.
;; used in menu.lisp/(draw menu)
(defmethod update-cursor-position ((object menu))
"Update the cursor position of a menu after it is drawn.
Place the cursor, when it is visible, on the first char of the current item."
(setf (cursor-position (window object)) (current-item-location object))
(refresh (window object)))
(defmethod update-cursor-position ((object checklist))
"Update the cursor position of a checklist after it is drawn.
Place the cursor between the brackets [_] of the current item."
(with-accessors ((pos current-item-location) (win window)) object
(move win
(car pos)
(1+ (cadr pos))) ;; put the cursor after the [
(refresh win)))
(defmethod update-cursor-position ((checkbox checkbox))
"Update the cursor position of a checkbox."
(with-accessors ((pos location) (win window)) checkbox
(move win
(car pos)
(1+ (cadr pos))) ;; put the cursor after the [
(refresh win) ))
(defmethod update-cursor-position ((field field))
"Update the cursor position of a field."
(with-accessors ((pos location) (inptr input-pointer) (dptr display-pointer) (win window)) field
(move win
;; TODO: assumes a single-line field.
(car pos)
(+ (cadr pos) ; beginning of the field
(- inptr dptr) )) ; position in the field starting with dptr
(refresh win)))
(defmethod update-cursor-position ((form form))
"Move the cursor to the correct position in current element of the form."
(update-cursor-position (current-element form)))
(defgeneric draw (object)
(:documentation "Draw objects (form, field, menu) to their associated window."))
(defmethod draw ((label label))
(with-accessors ((pos location) (win window) (name name) (title title) (width width) (style style) (reference reference)
(parent-form parent-form)) label
;; pick the string to write in the following order
;; title of the label
;; title of the referenced element
;; name of the referenced element
;; name of the label
(let* ((text (or title
(title (find-element parent-form reference))
(name (find-element parent-form reference))
name))
(string (when text (format nil "~A" text)))
(fg-style (getf style :foreground))
(bg-style (getf style :background))
(bg-char (if (getf bg-style :simple-char) (getf bg-style :simple-char) #\space)))
(when string
;; first draw the background, but only if width > string
(when width
(apply #'move win pos)
(add win bg-char :style bg-style :n width))
;; then the label over the background
(apply #'move win pos)
(add-string win string :style fg-style)))))
(defmethod draw ((button button))
(with-accessors ((pos location) (name name) (title title) (win window) (selected selectedp) (style style)) button
(apply #'move win pos)
(let* ((fg-style (if selected (getf style :selected-foreground) (getf style :foreground))))
(add-string win (format nil "<~A>" (if title title name)) :style fg-style))))
(defmethod draw ((checkbox checkbox))
(with-accessors ((pos location) (name name) (win window) (selected selectedp) (style style)
(checkedp checkedp)) checkbox
(apply #'move win pos)
(let* ((fg-style (if selected (getf style :selected-foreground) (getf style :foreground))))
(add-string win (format nil "[~A]" (if checkedp "X" "_")) :style fg-style)
(update-cursor-position checkbox))))
(defmethod draw ((field field))
"Clear and redraw the field and its contents and background."
(with-accessors ((pos location) (width width) (inbuf buffer) (inptr input-pointer) (dptr display-pointer)
(selected selectedp) (win window) (title title) (style style)) field
(let* ((fg-style (if selected (getf style :selected-foreground) (getf style :foreground)))
(len (length inbuf))
(val (value field))
(str (if (< len width)
;; if the buffer is shorter than the field, just display it.
val
;; otherwise display a substring starting with dptr.
;; display only max width chars starting from dptr
(subseq val dptr (if (< width (- len dptr))
;; if the remaining substring is longer than width, display just width chars.
(+ dptr width)
;; if the remaining substring is shorter than width, just display it.
len) ))))
(clear field)
(apply #'move win pos)
(add-string win str :style fg-style)
(update-cursor-position field))))
(defmethod draw ((form form))
"Draw the form by drawing the elements, then moving the cursor to the current element."
(with-accessors ((elements elements) (window window)) form
(loop for element in elements do
(draw element))
;; after drawing the elements, reposition the cursor to the current element
(update-cursor-position form)))
(defmethod draw ((form form-window))
"Draw the form by drawing the elements, then moving the cursor to the current element."
;; update cursor position only refreshes the window associated with the form, which is the sub-window
;; in order to see the border, we have to touch and refresh the parent border window.
;; refreshing the parent window has to be done before refreshing the cursor position in the sub
;; or the cursor will be moved to 0,0 of the parent window.
(touch form)
(refresh form)
;; draw the form contents, the superclass of form-window is form (and decorated-window).
(call-next-method))
;; previous-element and next-element are the only two elements where the current-element-number is changed.
;; here also current-element and selected has to be set.
(defun select-previous-element (form event &rest args)
"Select the previous element in a form's element list."
;;(declare (special form))
(with-accessors ((elements elements) (current-element-number current-element-number) (current-element current-element) (win window)) form
(setf (selectedp current-element) nil)
;; use mod to cycle the element list.
(setf current-element-number (mod (- current-element-number 1) (length elements)))
(setf current-element (nth current-element-number elements))
;; ignore inactive elements like labels.
(if (activep current-element)
(progn
(setf (selectedp current-element) t)
;; after we switched the element number, we also have to redraw the form.
(draw form))
(select-previous-element form event))))
(defun select-next-element (form event &rest args)
"Select the next element in a form's element list."
;;(declare (special form))
(with-accessors ((elements elements) (current-element-number current-element-number) (current-element current-element) (win window)) form
(setf (selectedp current-element) nil)
;; use mod to cycle the element list.
(setf current-element-number (mod (+ current-element-number 1) (length elements)))
(setf current-element (nth current-element-number elements))
;; ignore inactive elements like labels.
(if (activep current-element)
(progn
(setf (selectedp current-element) t)
;; after we switched the element number, we also have to redraw the form.
(draw form))
(select-next-element form event))))
(defun move-previous-char (field event &rest args)
"Move the cursor to the previous char in the field."
(with-accessors ((inptr input-pointer) (dptr display-pointer) (win window)) field
(when (> inptr 0)
(decf inptr))
;; when the inptr moves left past the dptr, simultaneously decf the dptr.
(when (< inptr dptr)
(decf dptr))
(draw field)))
(defun move-next-char (field event &rest args)
"Move the cursor to the next char in the field."
(with-accessors ((width width) (inbuf buffer) (inptr input-pointer) (dptr display-pointer) (mlen max-buffer-length)
(win window)) field
(when (and (< inptr (length inbuf))
(not (= (1+ inptr) mlen width)))
(incf inptr))
;; when the inptr moves right past the width, simultaneously incf the dptr.
(when (and (>= inptr (+ dptr width))
(not (= inptr mlen width)))
(incf dptr))
(draw field)))
(defun delete-previous-char (field event &rest args)
"Delete the previous char in the field, moving the cursor to the left."
(with-accessors ((inbuf buffer) (inptr input-pointer) (dptr display-pointer) (win window)) field
(when (> inptr 0)
(decf inptr)
(when (> dptr 0)
(decf dptr))
(setf inbuf (remove-nth (- (length inbuf) 1 inptr) inbuf)))
;; we dont have to redraw the complete form, just the changed field.
(draw field)))
(defun delete-next-char (field event &rest args)
"Delete the next char (char under the cursor) in the field, not moving the cursor."
(with-accessors ((inbuf buffer) (inptr input-pointer) (dptr display-pointer) (win window)) field
;; we can only delete to the right if the inptr is not at the end of the inbuf.
(when (> (length inbuf) inptr)
(when (> dptr 0)
;; when a part of the string is hidden on the left side, shift it to the right.
(decf dptr))
(setf inbuf (remove-nth (- (length inbuf) (1+ inptr)) inbuf)))
(draw field)))
(defun field-add-char (field char &rest args)
"Add char to the current cursor position in the field.
The buffer can be longer than the displayed field width, horizontal scrolling is enabled."
(if (and (characterp char) (graphic-char-p char))
(progn
(with-accessors ((width width) (inbuf buffer) (mlen max-buffer-length) (inptr input-pointer)
(dptr display-pointer) (win window)) field
(let ((len (length inbuf)))
(if (insert-mode-p win)
;; insert mode
(progn
;; only add new chars until we've reached the max-buffer-length
(unless (>= len mlen)
;; if we're at the end of the inbuf
(if (= inptr len)
;; just add another char to the inbuf
(setf inbuf (cons char inbuf))
;; if we're in the middle of the buffer, either insert or replace
(setf inbuf (insert-nth (- len inptr) char inbuf)) )
;; we need special cases when mlen is exactly equal to width.
(if (= mlen width)
;; advance the cursor if it is not already at the end
;; if scrolling is disabled, do not move past the last char in the field.
(unless (>= inptr (- mlen 1))
(incf inptr))
(unless (> inptr (- mlen 1))
(incf inptr))))
;; after updating the fill-pointer, update the display-pointer
(if (< inptr dptr) (decf dptr))
(if (> inptr (+ dptr (1- width))) (incf dptr)))
;; default overwrite mode
(progn
;; only add new chars until we've reached the max-buffer-length then only overwrite.
(if (>= len mlen)
(if (< inptr mlen)
;; even when the inbuf is full, when inptr is not at the end, overwrite.
(setf inbuf (replace-nth (- len (1+ inptr)) char inbuf))
nil)
;; if we're at the end of the inbuf
(if (= inptr len)
;; just add another char to the inbuf
(setf inbuf (cons char inbuf))
;; if we're in the middle of the buffer, either insert or replace
(setf inbuf (replace-nth (- len (1+ inptr)) char inbuf))))
;; we need special cases when mlen is exactly equal to width.
(if (= mlen width)
;; advance the cursor if it is not already at the end
;; if scrolling is disabled, do not move past the last char in the field.
(unless (>= inptr (- mlen 1))
(incf inptr))
(unless (> inptr (- mlen 1))
(incf inptr)))
;; after updating the fill-pointer, update the display-pointer
(when (< inptr dptr) (decf dptr))
(if (<= mlen width)
;; if scrolling is disabled, do not move past the last char in the field.
(when (> inptr (+ dptr width))
(incf dptr))
(when (> inptr (+ dptr (1- width)))
(incf dptr))) ))))
(draw field))
;; if the char isnt graphic, do nothing.
;; TODO: this doesnt work with acs chars, which are keywords.
nil))
(defun debug-print-field-buffer (object event &rest args)
(declare (ignore event))
(typecase object
(field
(with-accessors ((inbuf buffer) (inptr input-pointer) (dptr display-pointer) (win window)) object
(when (> (length inbuf) 0)
(clear win)
(format win "~A ~%" (value object))
(setf inbuf nil inptr 0 dptr 0))))
;; when we want to debug the whole form.
(form
(debug-print-field-buffer (current-element object) event)))
(draw object))
(defun cancel (object event &rest args)
"Associate this function with an event (key binding or button) to exit the event loop of a form or form element.
The first return value is nil, emphasizing that the user has canceled the form.
The second value is a list containing the object, the event that called the exit and the args passed.
This allows to specify why the form was canceled."
;; TODO: should this be done by the routine or explicitely by the user?
(when (eq (type-of object) 'form)
(reset-form object event))
(throw (if (eq (type-of object) 'form)
object
(if (parent-form object)
(parent-form object)
object))
(values nil (list object event args))))
(defun accept (object event &rest args)
"Associate this function with an event (key binding or button) to exit the event loop of a form or form element.
The first return value is t, emphasizing that the user has accepted the form.
The second value is a list containing the object, the event that called the exit and the args passed.
This allows to specify by which button or event the form was accepted."
;; if the object has a parent-form, do not throw the object, throw its parent form, otherwise throw the object.
(throw (if (eq (type-of object) 'form)
object
(if (parent-form object)
(parent-form object)
object))
(values t (list object event args))))
(defun reset-field (field event &rest args)
"Clear the field and reset its internal buffers and pointers."
(with-accessors ((inbuf buffer) (inptr input-pointer) (dptr display-pointer) (win window)) field
(clear field)
(setf inbuf nil inptr 0 dptr 0)))
(defun reset-form (object event &rest args)
(declare (ignore event))
(let ((form (typecase object
(form object)
(t (parent-form object)))))
(loop for element in (elements form)
do (when (and (typep element 'field) (activep element))
(with-accessors ((inbuf buffer) (inptr input-pointer) (dptr display-pointer) (win window)) element
(setf inbuf nil
inptr 0
dptr 0))))
(draw form)))
(define-keymap 'form-map
(list
;; C-a = ^A = #\soh = 1 = start of heading
;; exit the edit loop, return t
#\soh 'accept
;; C-x = cancel = CAN = #\can
;; exit the edit loop, return nil
#\can 'cancel
;; C-r = reset = DC2 = #\dc2
;; reset editable elements of the form (fields, checkboxes)
#\dc2 'reset-form
:btab 'select-previous-element
#\tab 'select-next-element))
(define-keymap 'field-map
(list
;; C-a = ^A = #\soh = 1 = start of heading
;; exit the edit loop, return t
#\soh 'accept
;; C-x = cancel = CAN = #\can
;; exit the edit loop, return nil
#\can 'cancel
;; C-r = reset = DC2 = #\dc2
;; reset the field
#\dc2 'reset-field
:left 'move-previous-char
:right 'move-next-char
:backspace 'delete-previous-char
:dc 'delete-next-char
:ic (lambda (field event &rest args)
(setf (insert-mode-p (window field)) (not (insert-mode-p (window field)))))
t 'field-add-char))
(defun call-button-function (button event &rest args)
(declare (ignore event))
(when (callback button)
(funcall (callback button) button event)))
(defun toggle-checkbox (checkbox event &rest args)
(declare (ignore event))
(setf (checkedp checkbox) (not (checkedp checkbox)))
(draw checkbox))
;; How to automatically bind a hotkey to every button?
;; that hotkey would have to be added to the form keymap, not to that of a button.
;; that would be like a global keymap, in contrast to an elements local keymap.
(define-keymap 'button-map
(list
#\space 'call-button-function
#\newline 'call-button-function))
(define-keymap 'checkbox-map
(list
#\space 'toggle-checkbox
#\x 'toggle-checkbox))
(defun edit (object &rest args)
(draw object)
;; since we have args passed to run-event-loop, all handler functions have to accept
;; a &rest args argument.
(apply #'run-event-loop object args))

36
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/get_wch.lisp Normal file
View file

@ -0,0 +1,36 @@
(in-package :de.anvi.croatoan)
(defun get-wide-char (window &key y x)
"Read in a wide C wchar_t (multi-byte) from the keyboard and return it.
If the destination coordinates y (row) and x (column) are given, move
the cursor to the destination first and then read a multi-byte char.
The window from which the char is read is automatically refreshed."
(when (and y x) (move window y x))
(with-foreign-object (ptr 'wint_t)
;; #define KEY_CODE_YES 0400 /* A wchar_t contains a key code */
;; if the char is a function key, return t as a second value, otherwise nil.
(if (= 256 (%wget-wch (winptr window) ptr))
(values (mem-ref ptr 'wint_t) t)
(values (mem-ref ptr 'wint_t) nil))))
(defun get-wide-event (window)
"Return a single user input event.
An event can be a lisp character or a keyword representing a function or mouse key.
If input-blocking is nil for the window, return nil if no key was typed."
(multiple-value-bind (ch function-key-p) (get-wide-char window)
(cond
;; for wide chars, if no input is waiting in non-blocking mode, ERR=0 is returned.
;; for normal chars, ERR=-1.
((= ch 0) nil)
(function-key-p
(let ((ev (function-key ch)))
(if (eq ev :mouse)
(multiple-value-bind (mev y x) (get-mouse-event)
(values mev y x)) ; returns 3 values, see mouse.lisp
ev)))
(t (code-char ch)))))

520
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/getch.lisp Normal file
View file

@ -0,0 +1,520 @@
(in-package :de.anvi.croatoan)
(defun get-char (window &key y x)
"Read in a C char (single byte) from the keyboard and return it.
If the destination coordinates y (row) and x (column) are given, move
the cursor to the destination first and then read a single byte.
The window from which the char is read is automatically refreshed."
(let ((winptr (winptr window)))
(cond ((and y x)
(%mvwgetch winptr y x))
(t
(%wgetch winptr)))))
;; takes a simple C chtype and puts it back into the read buffer.
;; it will be read with the next get-char.
(defun unget-char (chtype)
(%ungetch chtype))
;; takes an C int denoting a key. returns t or nil.
;; checks whether a function key is supported by the current terminal.
(defun key-supported-p (key-char)
(%has-key key-char))
;;; NOTES
;; All those return a simple C char (or int), not a rendered chtype (unsigned long int).
;; you can use code-char to convert this simple char/int to a lisp char.
;; but you cannot use this to convert a chtype to a lisp char.
;;; TODOs
;; [ ] Escape sequences. They are neither function keys nor chars.
;; keys above the first 0-255 chars. cannot fit in a char variable any more.
;; http://tldp.org/HOWTO/NCURSES-Programming-HOWTO/keys.html
(defparameter *key-alist*
'((:code_yes . 256)
(:min . 257)
(:break . 257)
(:down . 258)
(:up . 259)
(:left . 260)
(:right . 261)
(:home . 262) ; Pos1
(:backspace . 263)
(:f0 . 264)
(:f1 . 265)
(:f2 . 266)
(:f3 . 267)
(:f4 . 268)
(:f5 . 269)
(:f6 . 270)
(:f7 . 271)
(:f8 . 272)
(:f9 . 273)
(:f10 . 274)
(:f11 . 275)
(:f12 . 276)
(:f13 . 277)
(:f14 . 278)
(:f15 . 279)
(:f16 . 280)
(:f17 . 281)
(:f18 . 282)
(:f19 . 283)
(:f20 . 284)
(:f21 . 285)
(:f22 . 286)
(:f23 . 287)
(:f24 . 288)
(:f25 . 289)
(:f26 . 290)
(:f27 . 291)
(:f28 . 292)
(:f29 . 293)
(:f30 . 294)
(:f31 . 295)
(:f32 . 296)
(:f33 . 297)
(:f34 . 298)
(:f35 . 299)
(:f36 . 300)
(:f37 . 301)
(:f38 . 302)
(:f39 . 303)
(:f40 . 304)
(:f41 . 305)
(:f42 . 306)
(:f43 . 307)
(:f44 . 308)
(:f45 . 309)
(:f46 . 310)
(:f47 . 311)
(:f48 . 312)
(:f49 . 313)
(:f50 . 314)
(:f51 . 315)
(:f52 . 316)
(:f53 . 317)
(:f54 . 318)
(:f55 . 319)
(:f56 . 320)
(:f57 . 321)
(:f58 . 322)
(:f59 . 323)
(:f60 . 324)
(:f61 . 325)
(:f62 . 326)
(:f63 . 327)
(:dl . 328)
(:il . 329)
(:dc . 330)
(:ic . 331)
(:eic . 332)
(:clear . 333)
(:eos . 334)
(:eol . 335)
(:sf . 336) ; :shift-down
(:sr . 337) ; :shift-up
(:npage . 338)
(:ppage . 339)
(:stab . 340)
(:ctab . 341)
(:catab . 342)
(:enter . 343)
(:sreset . 344)
(:reset . 345)
(:print . 346)
(:ll . 347)
(:a1 . 348)
(:a3 . 349)
(:b2 . 350)
(:c1 . 351)
(:c3 . 352)
(:btab . 353) ; Shift + TAB = #\LATIN_SMALL_LETTER_S_WITH_CARON = sch
(:beg . 354)
(:cancel . 355)
(:close . 356)
(:command . 357)
(:copy . 358)
(:create . 359)
(:end . 360) ; Ende
(:exit . 361)
(:find . 362)
(:help . 363)
(:mark . 364)
(:message . 365)
(:move . 366)
(:next . 367)
(:open . 368)
(:options . 369)
(:previous . 370)
(:redo . 371)
(:reference . 372)
(:refresh . 373)
(:replace . 374)
(:restart . 375)
(:resume . 376)
(:save . 377)
(:sbeg . 378)
(:scancel . 379)
(:scommand . 380)
(:scopy . 381)
(:screate . 382)
(:sdc . 383)
(:sdl . 384)
(:select . 385)
(:send . 386) ; Shift-End
(:seol . 387)
(:sexit . 388)
(:sfind . 389)
(:shelp . 390)
(:shome . 391) ; Shift-Home, Shift-Pos1
(:sic . 392)
(:sleft . 393)
(:smessage . 394)
(:smove . 395)
(:snext . 396)
(:soptions . 397)
(:sprevious . 398)
(:sprint . 399)
(:sredo . 400)
(:sreplace . 401)
(:sright . 402)
(:srsume . 403)
(:ssave . 404)
(:ssuspend . 405)
(:sundo . 406)
(:suspend . 407)
(:undo . 408)
(:mouse . 409)
(:resize . 410)
(:event . 411)
(:max . 511) ; Alt-Delete
;; The following codes are not part of ncurses because they are not portable, i.e. they do not
;; exist on all terminals.
;; These are tested on xterm / gnome-terminal
;; :shift-delete = :sdc
(:shift-alt-delete . 512)
(:ctrl-delete . 513) ; Ctrl-Delete
(:shift-ctrl-delete . 514) ; Shift-Control-Delete
;; :shift-down = :sf = 336
(:alt-down . 517)
(:shift-alt-down . 518)
(:ctrl-down . 519)
(:shift-ctrl-down . 520)
;; (:shift-alt-ctrl-down . xxx) ;; hijacked by the ubuntu unity wm.
(:alt-end . 522)
(:shift-alt-end . 523)
(:ctrl-end . 524)
(:shift-ctrl-end . 525)
(:ctrl-alt-end . 526)
;; :shift-ctrl-alt-end . xxx
(:alt-home . 527)
(:shift-alt-home . 528)
(:ctrl-home . 529)
(:shift-ctrl-home . 530)
(:ctrl-alt-home . 531)
(:alt-insert . 532) ; Alt-Insert
;; :shift-insert = middle mouse button paste, probably 513, hijacked by xterm.
(:ctrl-insert . 534) ; Ctrl-Insert
(:ctrl-alt-insert . 536) ; Ctrl-Alt-Insert
;; Shift-Ctrl-Alt-Insert = ^[ [ 3 ; 8 ~
(:alt-left . 537)
(:shift-alt-right . 538)
(:ctrl-left . 539)
(:shift-ctrl-left . 540)
;; npage
;; :shift-npage
(:alt-npage . 542)
(:ctrl-npage . 544)
(:ctrl-alt-npage . 546)
;; :ppage
;; :shift-ppage activates an xterm ppage function
(:alt-ppage . 547)
(:ctrl-ppage . 549)
(:ctrl-alt-ppage . 551)
(:alt-right . 552)
(:shift-alt-right . 553)
(:ctrl-right . 554)
(:shift-ctrl-left . 555)
;; :shift-up = :sr = 337
(:alt-up . 558)
(:shift-alt-up . 559)
(:ctrl-up . 560)
(:shift-ctrl-up . 561)))
;; (:shift-alt-ctrl-up . xxx)
;; Takes a short int returned by get-char,
;; returns a keyword represeting the function key.
;; returns nil if number is not in the list.
(defun function-key (number)
(car (rassoc number *key-alist*)))
;; Returns t if the number is a key, nil if it is a char.
(defun function-key-p (number)
(if (and (> number 255)
(rassoc number *key-alist*))
t
nil))
;; http://rosettacode.org/wiki/Keyboard_input/Keypress_check
;; Returns t if a key has been pressed and a char can be read by get-char.
;; Requires input-blocking for window to be set to nil.
(defun key-pressed-p (window)
(let ((ch (get-char window)))
;; ncurses get-char returns -1 when no key was pressed.
(unless (= ch -1)
;; if a key was pressed, put it back into the input buffer so it can be rad by the next call to get-char.
(unget-char ch)
;; Return t.
t)))
;; works only when input-blocking is set to nil. enable-fkeys should also be t.
;; events can be handled with case.
;; events can be nil (no key pressed), characters #\a and function keys like :up, :down, etc.
;; todo: mouse, resizekey
(defun get-event (window)
;; doesnt really get a "char", but a single byte, which can be a char.
(let ((ch (get-char window)))
(cond
;; -1 means no key has been pressed.
((= ch -1) nil)
;; 0-255 are regular chars, whch can be converted to lisp chars with code-char.
((and (>= ch 0) (<= ch 255)) (code-char ch))
;; if the code belongs to a known function key, return a keyword symbol.
((function-key-p ch)
(let ((ev (function-key ch)))
(if (eq ev :mouse)
(multiple-value-bind (mev y x) (get-mouse-event)
(values mev y x)) ; returns 3 values, see mouse.lisp
ev)))
;; todo: unknown codes, like mouse, resize and unknown function keys.
(t
;;(error "invalid value of char received from ncurses.")
(princ ch window)))))
#|
;; I dont want them defined as octal literals.
'((:code_yes . #o400)
(:min . #o401)
(:break . #o401)
(:down . #o402)
(:up . #o403)
(:left . #o404)
(:right . #o405)
(:home . #o406)
(:backspace . #o407)
(:f0 . #o410)
;; how to handle this???
;; F(n) (KEY_F0+(n)) /* Value of function key n */
;; (loop for i from 1 to 63 do (format t "(:f~A . ~A)~%" i (+ F0 i)))
(:dl . #o510)
(:il . #o511)
(:dc . #o512)
(:ic . #o513)
(:eic . #o514)
(:clear . #o515)
(:eos . #o516)
(:eol . #o517)
(:sf . #o520)
(:sr . #o521)
(:npage . #o522)
(:ppage . #o523)
(:stab . #o524)
(:ctab . #o525)
(:catab . #o526)
(:enter . #o527)
(:sreset . #o530)
(:reset . #o531)
(:print . #o532)
(:ll . #o533)
(:a1 . #o534)
(:a3 . #o535)
(:b2 . #o536)
(:c1 . #o537)
(:c3 . #o540)
(:btab . #o541)
(:beg . #o542)
(:cancel . #o543)
(:close . #o544)
(:command . #o545)
(:copy . #o546)
(:create . #o547)
(:end . #o550)
(:exit . #o551)
(:find . #o552)
(:help . #o553)
(:mark . #o554)
(:message . #o555)
(:move . #o556)
(:next . #o557)
(:open . #o560)
(:options . #o561)
(:previous . #o562)
(:redo . #o563)
(:reference . #o564)
(:refresh . #o565)
(:replace . #o566)
(:restart . #o567)
(:resume . #o570)
(:save . #o571)
(:sbeg . #o572)
(:scancel . #o573)
(:scommand . #o574)
(:scopy . #o575)
(:screate . #o576)
(:sdc . #o577)
(:sdl . #o600)
(:select . #o601)
(:send . #o602)
(:seol . #o603)
(:sexit . #o604)
(:sfind . #o605)
(:shelp . #o606)
(:shome . #o607)
(:sic . #o610)
(:sleft . #o611)
(:smessage . #o612)
(:smove . #o613)
(:snext . #o614)
(:soptions . #o615)
(:sprevious . #o616)
(:sprint . #o617)
(:sredo . #o620)
(:sreplace . #o621)
(:sright . #o622)
(:srsume . #o623)
(:ssave . #o624)
(:ssuspend . #o625)
(:sundo . #o626)
(:suspend . #o627)
(:undo . #o630)
(:mouse . #o631)
(:resize . #o632)
(:event . #o633)
(:max . #o777)))
#define KEY_CODE_YES 0400 /* A wchar_t contains a key code */
#define KEY_MIN 0401 /* Minimum curses key */
#define KEY_BREAK 0401 /* Break key (unreliable) */
#define KEY_DOWN 0402 /* down-arrow key */
#define KEY_UP 0403 /* up-arrow key */
#define KEY_LEFT 0404 /* left-arrow key */
#define KEY_RIGHT 0405 /* right-arrow key */
#define KEY_HOME 0406 /* home key */
#define KEY_BACKSPACE 0407 /* backspace key */
#define KEY_F0 0410 /* Function keys. Space for 64 */
#define KEY_F(n) (KEY_F0+(n)) /* Value of function key n */
#define KEY_DL 0510 /* delete-line key */
#define KEY_IL 0511 /* insert-line key */
#define KEY_DC 0512 /* delete-character key */
#define KEY_IC 0513 /* insert-character key */
#define KEY_EIC 0514 /* sent by rmir or smir in insert mode */
#define KEY_CLEAR 0515 /* clear-screen or erase key */
#define KEY_EOS 0516 /* clear-to-end-of-screen key */
#define KEY_EOL 0517 /* clear-to-end-of-line key */
#define KEY_SF 0520 /* scroll-forward key */
#define KEY_SR 0521 /* scroll-backward key */
#define KEY_NPAGE 0522 /* next-page key */
#define KEY_PPAGE 0523 /* previous-page key */
#define KEY_STAB 0524 /* set-tab key */
#define KEY_CTAB 0525 /* clear-tab key */
#define KEY_CATAB 0526 /* clear-all-tabs key */
#define KEY_ENTER 0527 /* enter/send key */
#define KEY_SRESET 0530 /* Soft (partial) reset (unreliable) */
#define KEY_RESET 0531 /* Reset or hard reset (unreliable) */
#define KEY_PRINT 0532 /* print key */
#define KEY_LL 0533 /* lower-left key (home down) */
#define KEY_A1 0534 /* upper left of keypad */
#define KEY_A3 0535 /* upper right of keypad */
#define KEY_B2 0536 /* center of keypad */
#define KEY_C1 0537 /* lower left of keypad */
#define KEY_C3 0540 /* lower right of keypad */
#define KEY_BTAB 0541 /* back-tab key */
#define KEY_BEG 0542 /* begin key */
#define KEY_CANCEL 0543 /* cancel key */
#define KEY_CLOSE 0544 /* close key */
#define KEY_COMMAND 0545 /* command key */
#define KEY_COPY 0546 /* copy key */
#define KEY_CREATE 0547 /* create key */
#define KEY_END 0550 /* end key */
#define KEY_EXIT 0551 /* exit key */
#define KEY_FIND 0552 /* find key */
#define KEY_HELP 0553 /* help key */
#define KEY_MARK 0554 /* mark key */
#define KEY_MESSAGE 0555 /* message key */
#define KEY_MOVE 0556 /* move key */
#define KEY_NEXT 0557 /* next key */
#define KEY_OPEN 0560 /* open key */
#define KEY_OPTIONS 0561 /* options key */
#define KEY_PREVIOUS 0562 /* previous key */
#define KEY_REDO 0563 /* redo key */
#define KEY_REFERENCE 0564 /* reference key */
#define KEY_REFRESH 0565 /* refresh key */
#define KEY_REPLACE 0566 /* replace key */
#define KEY_RESTART 0567 /* restart key */
#define KEY_RESUME 0570 /* resume key */
#define KEY_SAVE 0571 /* save key */
#define KEY_SBEG 0572 /* shifted begin key */
#define KEY_SCANCEL 0573 /* shifted cancel key */
#define KEY_SCOMMAND 0574 /* shifted command key */
#define KEY_SCOPY 0575 /* shifted copy key */
#define KEY_SCREATE 0576 /* shifted create key */
#define KEY_SDC 0577 /* shifted delete-character key */
#define KEY_SDL 0600 /* shifted delete-line key */
#define KEY_SELECT 0601 /* select key */
#define KEY_SEND 0602 /* shifted end key */
#define KEY_SEOL 0603 /* shifted clear-to-end-of-line key */
#define KEY_SEXIT 0604 /* shifted exit key */
#define KEY_SFIND 0605 /* shifted find key */
#define KEY_SHELP 0606 /* shifted help key */
#define KEY_SHOME 0607 /* shifted home key */
#define KEY_SIC 0610 /* shifted insert-character key */
#define KEY_SLEFT 0611 /* shifted left-arrow key */
#define KEY_SMESSAGE 0612 /* shifted message key */
#define KEY_SMOVE 0613 /* shifted move key */
#define KEY_SNEXT 0614 /* shifted next key */
#define KEY_SOPTIONS 0615 /* shifted options key */
#define KEY_SPREVIOUS 0616 /* shifted previous key */
#define KEY_SPRINT 0617 /* shifted print key */
#define KEY_SREDO 0620 /* shifted redo key */
#define KEY_SREPLACE 0621 /* shifted replace key */
#define KEY_SRIGHT 0622 /* shifted right-arrow key */
#define KEY_SRSUME 0623 /* shifted resume key */
#define KEY_SSAVE 0624 /* shifted save key */
#define KEY_SSUSPEND 0625 /* shifted suspend key */
#define KEY_SUNDO 0626 /* shifted undo key */
#define KEY_SUSPEND 0627 /* suspend key */
#define KEY_UNDO 0630 /* undo key */
#define KEY_MOUSE 0631 /* Mouse event has occurred */
#define KEY_RESIZE 0632 /* Terminal resize event */
#define KEY_EVENT 0633 /* We were interrupted by an event */
#define KEY_MAX 0777 /* Maximum key value is 0633 */
|#

19
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/getstr.lisp Normal file
View file

@ -0,0 +1,19 @@
(in-package :de.anvi.croatoan)
(defun get-string (window n &key y x)
"Read a string from the keyboard and return it.
Reading is performed until a newline or carriage return is received.
The terminating character is not included in the returned string.
If n is given, read at most n chars, to prevent a possible input
buffer overflow.
If the destination coordinates y and x are given, move the cursor
there first."
(let ((winptr (winptr window)))
(with-foreign-pointer-as-string (string n)
(cond ((and y x)
(%mvwgetnstr winptr y x string n))
(t
(%wgetnstr winptr string n))))))

54
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/getyx.lisp Normal file
View file

@ -0,0 +1,54 @@
(in-package :de.anvi.croatoan)
;; TODO: window auf winpter umstellen.
(defun cursor-position (window)
"Returns a cons pair of the current cursor coordinates (line-y . column-x) in window."
(cons (%getcury window)
(%getcurx window)))
(defun window-begin (window)
"Returns a cons pair of the top left beginning coordinates (y . x) of window."
(cons (%getbegy window)
(%getbegx window)))
(defun subwindow-relative-begin (subwindow)
"Returns a cons pair (y . x) of beginning coordinates of a subwindow relative to the parent window."
(cons (%getpary subwindow)
(%getparx subwindow)))
(defun window-size (window)
"Returns window size as a cons pair (height . width)."
(cons (%getmaxy window)
(%getmaxx window)))
;;; NOTES
#|
Those 4 C macros are defined in terms of other, simpler macros:
#define getyx(win,y,x) (y = getcury(win), x = getcurx(win))
#define getbegyx(win,y,x) (y = getbegy(win), x = getbegx(win))
#define getmaxyx(win,y,x) (y = getmaxy(win), x = getmaxx(win))
#define getparyx(win,y,x) (y = getpary(win), x = getparx(win))
And those simpler macros are just accessing the window struct.
#define getcurx(win) ((win) ? (win)->_curx : ERR)
#define getcury(win) ((win) ? (win)->_cury : ERR)
#define getbegx(win) ((win) ? (win)->_begx : ERR)
#define getbegy(win) ((win) ? (win)->_begy : ERR)
#define getmaxx(win) ((win) ? ((win)->_maxx + 1) : ERR)
#define getmaxy(win) ((win) ? ((win)->_maxy + 1) : ERR)
#define getparx(win) ((win) ? (win)->_parx : ERR)
#define getpary(win) ((win) ? (win)->_pary : ERR)
Those are defined as low-level functions in legacy.lisp.
|#
;;; TODOs
;; combine the 2 win and subwin functions into one by using opaque/is_subwin.

162
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/gray_streams.lisp Normal file
View file

@ -0,0 +1,162 @@
(in-package :de.anvi.croatoan)
#|
classes and methods for the gray stream interface.
http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html
http://www.gnu.org/software/clisp/impnotes/gray-gf-char-out.html
before including this, add trivial-gray-streams to asd or use the sb-gray stream package.
Up to now, window and screen had no superclasses, thus they were subclasses of standard-object.
Now, they will become bi-directional character streams.
That means that we dont need separate classes for defining streams, and that windows will have
a stream as a feature, windows now will _be_ specialized streams.
fundamental-character-output-stream
fundamental-character-input-stream
window
screen
subwin
For the existing code, nothing will change. we will still be able to use all ncurses and croatoan
functions.
Actually, we still _need_ those functions to define the gray stream functions. But once defined,
we will not need add-char and add-string any more, we will simply use Lisp's format, read, print, etc.
|#
;;;; libncursesw, wide IO
;;; Character Output stream
;;; Mandatory methods
;; write-char, format ~C
(defmethod stream-write-char ((stream window) (ch character))
(if (insert-mode-p stream)
(progn
(insert-wide-char stream ch)
;; move the cursor after the inserted character.
(move-direction stream :right))
(add-wide-char stream ch)))
;; 170830: #sbcl, according to stassats we can not specialize on the second argument,
;; so no complex chars or complex strings with the ~C directive.
;; use ~/xyz/ instead of ~C.
;; ~A uses print-object underneath, not gray streams, so it probably can be used.
#|
; SLIME 2.19
CL-USER> (defun xxx (&rest args)
(print (second args)))
XXX
CL-USER> xxx
; Evaluation aborted on #<UNBOUND-VARIABLE XXX {1002E0A433}>.
CL-USER> (xxx 1 2 3 4)
2
2
CL-USER> (format t "~/xxx/")
; Evaluation aborted on #<SB-FORMAT:FORMAT-ERROR {1003469493}>.
CL-USER> (format t "~/xxx/" 1)
1
NIL
CL-USER> (format t "~/xxx/" 11)
11
NIL
CL-USER>
|#
(defmethod stream-write-char ((stream window) (ch complex-char))
(add-wide-char stream ch))
;; Returns the column number where the next character would be written, i.e. the current x position
(defmethod stream-line-column ((stream window))
(%getcurx (winptr stream)))
;;; Non-mandatory methods
;; Default method uses repeated calls to stream-write-char
;; We can not specialize stream-write-string on complex-strings.
#|
(defmethod stream-write-string ((stream window) (str-orig string) &optional (start 0) (end nil))
;; TODO: either do something with start and end, or (declare (ignore start end))
(let ((str (subseq str-orig start end)))
;; TODO: we can not combine %wadd-wch and %waddstr
;; TODO: writing a normal string waddstr on a wide cchar background causes an SB-KERNEL::CONTROL-STACK-EXHAUSTED-ERROR
(%waddstr (winptr stream) str)))
|#
;;; Character Input Stream
;;; Mandatory methods: stream-read-char, stream-unread-char
(defmethod stream-read-char ((stream window))
(code-char (get-wide-char stream)))
(defmethod stream-unread-char ((stream window) (ch character))
(%unget-wch (char-code ch)))
;;;; libncurses, non-wide IO
;;; Character Output stream
;;; Mandatory methods: stream-write-char, stream-line-column
;; write-char, format ~C
;;(defmethod stream-write-char ((stream window) (ch character))
;; (let ((code (char-code ch))
;; (winptr (winptr stream)))
;; (if (insert-mode-p stream)
;; (progn
;; (%winsch winptr code)
;; ;; move the cursor after the inserted character.
;; (move-to stream :right))
;; (%waddch winptr code))))
;; write-char, format ~C
;;(defmethod stream-write-char ((stream window) (ch complex-char))
;; (%waddch (winptr stream) (x2c ch)))
;; print, prin1, princ, format ~A, ~S
;;(defmethod print-object ((ch complex-char) (stream window))
;; (%waddch (winptr stream) (x2c ch)))
;;
;;(defmethod print-object ((cstr complex-string) stream)
;; (loop for ch across (complex-char-array cstr)
;; do (princ (simple-char ch))))
;;
;;(defmethod print-object ((cstr complex-string) (stream window))
;; (loop for ch across (complex-char-array cstr)
;; do (add-char stream ch)))
;; Returns the column number where the next character would be written, i.e. the current y position
;;(defmethod stream-line-column ((stream window))
;; (%getcurx (winptr stream)))
;;; Non-mandatory methods
;; Default method uses repeated calls to stream-write-char
;;(defmethod stream-write-string ((stream window) (str string) &optional (start 0) (end nil))
;; ;; TODO: either do something with start and end, or (declare (ignore start end))
;; (%waddstr (winptr stream) str))
;;; Character Input Stream
;;(defmethod stream-read-char ((stream window))
;; (code-char (%wgetch (winptr stream))))
;;(defmethod stream-read-char-no-hang ((stream window))
;; %wgetch wie bei read-char, nur muss input-blocking nil sein.
;;(defmethod stream-unread-char ((stream window) (ch character))
;; (%ungetch (char-code ch)))
;; listen = read-char-no-hang + unread
;;(defmethod stream-listen ((stream window))

14
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/in_wch.lisp Normal file
View file

@ -0,0 +1,14 @@
(in-package :de.anvi.croatoan)
(defun extract-wide-char (window &key y x position)
"Extract and return a single wide (complex) character from the window.
This includes wide characters (code > 255), and requires the ncursesw library.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the character.
The position can also be passed in form of a two-element list."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(funcall-get-cchar_t #'%win-wch window))

14
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/inch.lisp Normal file
View file

@ -0,0 +1,14 @@
(in-package :de.anvi.croatoan)
(defun extract-char (window &key y x position)
"Extract and return the single-byte complex char from the window.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the character.
The position can also be passed in form of a two-element list."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let* ((winptr (winptr window))
(chtype (%winch winptr)))
(chtype2xchar chtype)))

21
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/inchstr.lisp Normal file
View file

@ -0,0 +1,21 @@
(in-package :de.anvi.croatoan)
(defun extract-complex-string (window &key y x position n)
"Extract and return a complex string from the window.
Start at the current cursor position and end at the right margin of window.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the character.
The position can also be passed in form of a two-element list.
If n is given, read at most n chars."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let* ((count (if n n (- (width window) (cadr (cursor-position window)))))
(complex-string (make-instance 'complex-string)))
(loop for i from 0 to (1- count) do
(vector-push-extend (extract-wide-char window) (complex-char-array complex-string))
(move-direction window :right))
complex-string))

31
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/initscr.lisp Normal file
View file

@ -0,0 +1,31 @@
(in-package :de.anvi.croatoan)
(defun init-screen ()
"Initializes the curses mode. Returns the main window."
(%initscr))
(defun end-screen ()
"Clean shutdown of the curses display."
(%endwin))
(defgeneric closed-p (s)
(:documentation "Check whether the screen has been closed without a subsequent call to refresh to reactivate it."))
(defmethod closed-p ((s screen))
(declare (ignore s))
(%isendwin))
(defun new-terminal (type out-fd in-fd)
"Use instead of init-screen when you want more than one terminal."
(%newterm type out-fd in-fd))
(defun set-current-terminal (new-screen)
"Sets new-screen as the current terminal. Returns the old screen."
(%set-term new-screen))
;;; TODOs
;; [ ] are files in lisp in newterm correctly represented by fd-s?
;; [ ] add type info either to the docs or in asserts.
;; [ ] document all possible return values and check for them.

82
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/inopts.lisp Normal file
View file

@ -0,0 +1,82 @@
(in-package :de.anvi.croatoan)
;; nodelay FALSE = getch blocking
;; nodelay TRUE = getch non-blocking.
;; halfdelay 5 = waits for 5/10 seconds.
;; halfdelay is turned off by nocbreak.
;; terminal input modes:
;;
;; canonical non canonical
;; line buffered character based
;; ctrl chars processed ^C,^S,^Q,^D processed no ctrl chars processed
;; cooked cbreak raw
;;
;; buffering t nil nil
;; control t t nil
;; | cooked | cbreak | raw
;; ----------+--------+--------+-----
;; buffering | t | nil | nil
;; ----------+--------+--------+-----
;; control | t | t | nil
;; The combination echo+getch should not be used during buffered input
(defun set-input-mode (input-buffering process-control-chars)
(if input-buffering
;; to turn on buffering, turn off cbreak or raw
(if process-control-chars (%nocbreak) (%noraw))
;; to turn off buffering, turn on cbreak or raw
(if process-control-chars (%cbreak) (%raw))))
;; Ported to clos, used in clos.
(defun set-input-blocking (window status)
"Set window input blocking behavior.
Possible values are t, nil and a blocking duration in (positive integer) miliseconds."
(cond ((eq status t) (%wtimeout window -1))
((eq status nil) (%wtimeout window 0))
((and (typep status 'integer) (plusp status))
(%wtimeout window status))
(t (error "possible blocking states: t, nil, delay in miliseconds"))))
;; Not used in clos because too simple. obsolete.
(defun set-input-echoing (flag)
"Set whether chars will be echoed on input."
(if flag
(%echo)
(%noecho)))
;; Not used in clos because too simple. obsolete.
(defun set-enable-fkeys (window flag)
"If flag is t, bind function keys to known codes when returned by get-char.
If flag is nil, F keys will be system-dependent multi-character escape codes."
(%keypad (winptr window) flag))
;; Obscure functions I never used before:
(defun flush-on-interrupt (window flag)
(%intrflush window flag))
(defun enable-8bit-char-input (window flag)
(%meta window flag))
(defun io-queue-flush (flag)
(if flag
(%qiflush)
(%noqiflush)))
;; if it would work at all, which it doesnt,
;; it would work only for (function-keys win t)
(defun escape-sequence-delay (window flag)
(%notimeout window flag))
(defun type-ahead-fd (fd)
(%typeahead fd))
;;; TODOs
;; [X] do not mix cbreak and raw. use either the one or the other.
;; [ ] for now, we consider only global optins. work in a window parameter as well.

56
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/ins_wch.lisp Normal file
View file

@ -0,0 +1,56 @@
(in-package :de.anvi.croatoan)
(defun insert-wide-char (window char &key attributes fgcolor bgcolor color-pair style y x position n)
"Insert char into window before the character currently under the cursor.
Chars right of the cursor are moved one position to the right.
The rightmost character on the line may be lost. The position of the
cursor is not changed.
char can be a simple character or a complex-char with attributes and colors.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the object.
The position can also be passed in form of a two-element list.
If n is given, insert n chars."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((attributes (if style
(getf style :attributes)
attributes))
(color-pair (cond (style
(list (getf style :fgcolor) (getf style :bgcolor)))
((or fgcolor bgcolor)
(list fgcolor bgcolor))
(t color-pair))))
(funcall-make-cchar_t #'%wins-wch window char attributes color-pair n)))
;; TODO: (defmethod insert (obj character))
;; (defmethod insert (obj string)) etc.
;; the same for echo (only chars) and add.
;; :x t :y t => keep the current row or column
(defun insert (window object &rest keys &key &allow-other-keys)
"Insert char or string into window before the char currently under the cursor.
Currently supported text objects are characters (simple and complex),
characters given by integer codes or keywords, and strings
(simple and complex).
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then insert the object.
The position can also be passed in form of a two-element list.
If n is given for a char, insert n chars.
If n is given for a string, add at most n chars from the string."
(let ((fn (typecase object
((or string complex-string)
#'insert-string)
((or integer keyword character complex-char)
#'insert-wide-char))))
(apply fn window object keys)))

28
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/insch.lisp Normal file
View file

@ -0,0 +1,28 @@
(in-package :de.anvi.croatoan)
(defun insert-char (window char &key attributes fgcolor bgcolor color-pair style y x position n)
"Insert char into window before the character currently under the cursor.
Chars right of the cursor are moved one position to the right.
The rightmost character on the line may be lost. The position of the
cursor is not changed.
char can be a simple character or a complex-char with attributes and colors.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the object.
The position can also be passed in form of a two-element list.
If n is given, insert n chars."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((attributes (if style
(getf style :attributes)
attributes))
(color-pair (cond (style
(list (getf style :fgcolor) (getf style :bgcolor)))
((or fgcolor bgcolor)
(list fgcolor bgcolor))
(t color-pair))))
(funcall-make-chtype #'%winsch window char attributes color-pair n)))

42
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/insstr.lisp Normal file
View file

@ -0,0 +1,42 @@
(in-package :de.anvi.croatoan)
(defun insert-string (window string &key attributes fgcolor bgcolor color-pair style y x position n)
"Insert string before the current position in window.
Chars right of the cursor are moved to the right. The rightmost chars
on the line may be lost. The cursor position is not changed.
If n is given, insert at most n chars from the string.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the object.
The position can also be passed in form of a two-element list."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((count (if n
n
;; we cant use length to determine the length of a complex string
;; because it is not a sequence.
(typecase string
(string (length string))
(complex-string (length (complex-char-array string)))))))
(typecase string
(string
;;(if (or attributes fgcolor bgcolor color-pair style)
;; lisp string combined with attributes and colors
(loop
repeat count
for ch across (reverse string)
do (insert-wide-char window ch :attributes attributes :fgcolor fgcolor :bgcolor bgcolor
:color-pair color-pair :style style)) )
;; simple lisp string, no attributes or colors
;; TODO 190826 we dont want to use this because we want to force color-set and bkgd to use separate colors
;;(if n
;; (%winsnstr (winptr window) string n)
;; (%winsstr (winptr window) string))))
(complex-string
(loop
repeat count
for ch across (reverse (complex-char-array string))
do (insert-wide-char window ch))))))

28
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/instr.lisp Normal file
View file

@ -0,0 +1,28 @@
(in-package :de.anvi.croatoan)
(defun extract-string (window &key y x position n)
"Extract and return a string from window.
Any attributes are stripped from the characters before the string is returned.
Start at the current cursor position and end at the right margin of window.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the character.
The position can also be passed in form of a two-element list.
If n is given, read at most n chars."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((len (if n n (distance-to-eol window))))
(with-foreign-pointer (string len)
;; zero the allocated foreign string first.
(setf (mem-ref string :char (1- len)) 0)
;; populate the foreign string with chars.
;; the c routines return ERR (-1) or the number of chars extracted.
(let ((retval (%winnstr (winptr window) string len)))
(if (= retval -1)
nil
;; convert the char pointer to a lisp string.
(foreign-string-to-lisp string))))))

25
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/inwstr.lisp Normal file
View file

@ -0,0 +1,25 @@
(in-package :de.anvi.croatoan)
(defun extract-wide-string (window &key y x position n)
"Extract and return a string from window.
Any attributes are stripped from the characters before the string is returned.
Start at the current cursor position and end at the right margin of window.
If the position coordinates y (row) and x (column) are given, move the
cursor to the position first and then add the character.
The position can also be passed in form of a two-element list.
If n is given, read at most n chars."
(when (and y x) (move window y x))
(when position (apply #'move window position))
(let ((count (if n n (distance-to-eol window)))
;; start with an empty string as buffer
(str (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t)))
(loop for i from 0 to (1- count) do
(vector-push-extend (simple-char (extract-wide-char window)) str)
(move-direction window :right))
;; return string buffer containing i chars
str))

9
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/kernel.lisp Normal file
View file

@ -0,0 +1,9 @@
(in-package :de.anvi.croatoan)
;; 0 invisible, 1 visible, 2 very visible.
(defun set-cursor-visibility (status)
(case status
((nil :invisible) (%curs-set 0))
((t :visible) (%curs-set 1))
(:very-visible (%curs-set 2))
(otherwise (error "Valid status arguments: nil, t, :very-visible"))))

27
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/key_defined.lisp Normal file
View file

@ -0,0 +1,27 @@
(in-package :croatoan)
;; key_defined
;; check if a keycode is defined
;; http://invisible-island.net/ncurses/man/key_defined.3x.html
;;; C prototypes
;; int key_defined(const char *definition);
;;; Low-level C functions
(defcfun ("key_defined" %key-defined) :int (definition :string))
;;; High-level Lisp wrappers
(defun key-defined-p (key-name)
"If keycode is defined, return the keycode."
(let ((retval (%key-defined key-name)))
(cond ((= retval 0) nil)
((= retval -1) nil)
(t retval))))
;;; TODOs
;; [ ] dont return any numeric codes, do something with keywords.
;; [ ] somehow handle the -1 error case.

24
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/keybound.lisp Normal file
View file

@ -0,0 +1,24 @@
(in-package :croatoan)
;; keybound
;; return definition of keycode
;; http://invisible-island.net/ncurses/man/keybound.3x.html
;;; C prototypes
;; char *keybound(int keycode, int count);
;;; Low-level C functions
(defcfun ("keybound" %keybound) :string (keycode :int) (count :int))
;;; High-level Lisp wrappers
(defun key-description (code n)
"Return the n-th description of key stored in the terminfo database."
(%keybound code n))
;;; TODOs
;; [ ] dont return any numeric codes, do something with keywords.
;; [ ] somehow handle the -1 error case.

39
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/legacy.lisp Normal file
View file

@ -0,0 +1,39 @@
(in-package :croatoan)
;;; legacy
;;; get curses cursor and window coordinates, attributes
;;; http://invisible-island.net/ncurses/man/curs_legacy.3x.html
;;; C prototypes
;; int getattrs(WINDOW *win);
;; int getbegx(WINDOW *win);
;; int getbegy(WINDOW *win);
;; int getcurx(WINDOW *win);
;; int getcury(WINDOW *win);
;; int getmaxx(WINDOW *win);
;; int getmaxy(WINDOW *win);
;; int getparx(WINDOW *win);
;; int getpary(WINDOW *win);
;;; Low-level C functions
(defcfun ("getbegx" %getbegx) :int (win window))
(defcfun ("getbegy" %getbegy) :int (win window))
(defcfun ("getcurx" %getcurx) :int (win window))
(defcfun ("getcury" %getcury) :int (win window))
(defcfun ("getmaxx" %getmaxx) :int (win window))
(defcfun ("getmaxy" %getmaxy) :int (win window))
(defcfun ("getparx" %getparx) :int (win window))
(defcfun ("getpary" %getpary) :int (win window))
;;; High-level Lisp wrappers
;; See getyx.lisp.
;;; NOTES
;;; TODOs
;; getattrs compare with attr_get

26
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/legacy_coding.lisp Normal file
View file

@ -0,0 +1,26 @@
(in-package :croatoan)
;;; legacy coding
;;; http://invisible-island.net/ncurses/man/legacy_coding.3x.html
;;; C prototypes
;; int use_legacy_coding(int level);
;;; Low-level C functions
(defcfun ("use_legacy_coding" %use-legacy-coding) :int (level :int))
;;; High-level Lisp wrappers
;; Possible values: 0 (default), 1 and 2.
(defun set-char-representation (level)
"Set how char-to-string will represent a char."
(%use-legacy-coding level))
;;; NOTES
;; This affects %unctrl/char-to-string. See util.lisp and the manpage.
;;; TODOs

344
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/menu.lisp Normal file
View file

@ -0,0 +1,344 @@
(in-package :de.anvi.croatoan)
;; menu
;; curses extension for programming menus
;; http://invisible-island.net/ncurses/man/menu.3x.html
(defun list2array (list dimensions)
"Example: (list2array '(a b c d e f) '(3 2)) => #2A((A B) (C D) (E F))"
(let ((m (car dimensions))
(n (cadr dimensions)))
(assert (= (length list) (* m n)))
(let ((array (make-array dimensions :initial-element nil)))
(loop for i from 0 to (- m 1)
do (loop for j from 0 to (- n 1)
do (setf (aref array i j) (nth (+ (* i n) j) list))))
array)))
;; TODO: see menu_format
(defun rmi2sub (layout rmi)
"Take array dimensions and an index in row-major order, return two subscripts.
Example: (rmi2sub '(2 3) 5) => (1 2)"
(let ((m (car layout))
(n (cadr layout)))
(assert (< rmi (* m n)))
(multiple-value-bind (q r) (floor rmi n)
(list q r))))
(defun sub2rmi (layout subs)
"Take array dimensions and two subscripts, return an index in row-major order.
Example: (sub2rmi '(2 3) '(1 2)) => 5"
(let ((m (car layout))
(n (cadr layout))
(i (car subs))
(j (cadr subs)))
(assert (and (< i m) (< j n)))
(+ (* i n) j)))
(defun update-menu (menu event)
"Take a menu and an event, update in-place the current item of the menu."
;; we need to make menu special in order to setf i in the passed menu object.
(declare (special menu))
(with-accessors ((current-item-number current-item-number) (current-item current-item) (items items)
(cyclic-selection cyclic-selection-p) (layout layout) (scrolled-layout scrolled-layout)
(scrolled-region-start scrolled-region-start)) menu
(let ((i (car (rmi2sub layout current-item-number)))
(j (cadr (rmi2sub layout current-item-number)))
(m (car layout))
(n (cadr layout))
(m0 (car scrolled-region-start))
(n0 (cadr scrolled-region-start))
(m1 (car scrolled-layout))
(n1 (cadr scrolled-layout)))
(if scrolled-layout
;; when scrolling is on, the menu is not cycled.
(progn
(case event
(:up (when (> i 0) (decf i)) ; when not in first row, move one row up
(when (< i m0) (decf m0))) ; when above region, move region one row up
(:down (when (< i (1- m)) (incf i)) ; when not in last row, move one row down
(when (>= i (+ m0 m1)) (incf m0))) ; when below region, move region one row down
(:left (when (> j 0) (decf j)) ; when not in first column, move one column left
(when (< j n0) (decf n0))) ; when left of region, move region one column left
(:right (when (< j (1- n)) (incf j)) ; when not in last column, move one column right
(when (>= j (+ n0 n1)) (incf n0)))) ; when right of region, move region one column right
;; set new scrolled-region coordinates
(setf scrolled-region-start (list m0 n0)))
;; when scrolling is off, the menu can be cycled.
(if cyclic-selection
;; do cycle through the items
(case event
(:up (setf i (mod (1- i) m)))
(:down (setf i (mod (1+ i) m)))
(:left (setf j (mod (1- j) n)))
(:right (setf j (mod (1+ j) n))))
;; dont cycle through the items
(case event
(:up (setf i (max (1- i) 0)))
(:down (setf i (min (1+ i) (1- m))))
(:left (setf j (max (1- j) 0)))
(:right (setf j (min (1+ j) (1- n)))))))
;; after updating i,j, update the current-item-number
(setf current-item-number (sub2rmi layout (list i j)))
;; after updating the current-item-number, update the pointer to the current-item.
(setf current-item (nth current-item-number items)) )))
(defun format-menu-item (menu item-number)
"Take a menu and return item item-number as a properly formatted string.
If the menu is a checklist, return [ ] or [X] at the first position.
If a mark is set for the current item, display the mark at the second position.
Display the same number of spaces for other items.
At the third position, display the item given by item-number."
(with-accessors ((items items)
(type menu-type)
(current-item-number current-item-number)
(current-item-mark current-item-mark)) menu
;; return as string
(format nil "~A~A~A"
;; two types of menus: :selection or :checklist
;; show the checkbox before the item in checklists
(if (eq type :checklist)
(if (checkedp (nth item-number items)) "[X] " "[ ] ")
"")
;; for the current item, draw the current-item-mark
;; for all other items, draw a space
(if (= current-item-number item-number)
current-item-mark
(make-string (length current-item-mark) :initial-element #\space))
;; then add the item name
(name (nth item-number items)) )))
(defun draw-menu-item (win menu item-number i j)
"Draw the item given by item-number at item position (i j) in the window."
(with-accessors ((current-item-number current-item-number)
(current-item-location current-item-location)
(max-item-length max-item-length)
(menu-location menu-location)) menu
(let (pos-y
pos-x)
(if menu-location
;; add an offset when menu-location is given
(setq pos-y (+ i (car menu-location))
pos-x (+ (* j max-item-length) (cadr menu-location)))
;; if a location is not given, display the menu starting at 0,0
(setq pos-y i
pos-x (* j max-item-length)))
(move win pos-y pos-x)
;; save the location of the current item, to be used in update-cursor-position.
(when (= item-number current-item-number)
(setf current-item-location (list pos-y pos-x))))
;; if the item is the current item, change its attributes
(let ((attr (if (= item-number current-item-number)
(list :reverse)
nil)))
;; delete the item by overwriting it with an empty string.
(save-excursion win (add win #\space :n max-item-length))
(change-attributes win max-item-length attr)
;; format the item text
;; display it in the window associated with the menu
(add win (format-menu-item menu item-number) :attributes attr))))
;; draws to any window, not just to a sub-window of a menu-window.
(defun draw-menu (window menu)
"Draw the menu to the window."
(with-accessors ((layout layout) (scrolled-layout scrolled-layout) (scrolled-region-start scrolled-region-start)) menu
(let ((m (car layout))
(n (cadr layout))
(m0 (car scrolled-region-start))
(n0 (cadr scrolled-region-start))
(m1 (car scrolled-layout))
(n1 (cadr scrolled-layout)))
(if scrolled-layout
;; when the menu is too big to be displayed at once, only a part
;; is displayed, and the menu can be scrolled
(loop for i from 0 to (1- m1)
do (loop for j from 0 to (1- n1)
do (let ((item-number (sub2rmi layout (list (+ m0 i) (+ n0 j)))))
;; the menu is given as a flat list, so we have to access it as a 2d array in row major order
(draw-menu-item window menu item-number i j))))
;; when there is no scrolling, and the whole menu is displayed at once
(loop for i from 0 to (1- m)
do (loop for j from 0 to (1- n)
do (let ((item-number (sub2rmi layout (list i j))))
(draw-menu-item window menu item-number i j)))) ))
(refresh window)))
(defmethod draw ((menu menu))
"Draw the menu to its associated window."
(draw-menu (window menu) menu)
;; when menu is a part of a form:
;; update-cursor-position = place the cursor on the current item
;; if the menu is a checklist, place the cursor inside the [_], like it is done with a single checkbox.
(update-cursor-position menu))
(defmethod draw ((menu menu-window))
"Draw the menu-window."
(with-accessors ((title title) (name name) (border draw-border-p) (sub-win sub-window)) menu
;; draw the menu to the sub-window
(draw-menu sub-win menu)
;; we have to explicitely touch the background win, because otherwise it wont get refreshed.
(touch menu)
;; draw the title only when we also have a border, because we draw the title on top of the border.
(when (and border title)
;; make a format template depending on the length of the title.
;; "|~12:@<~A~>|"
(flet ((make-title-string (len)
(concatenate 'string "|~" (write-to-string (+ len 2)) ":@<~A~>|")))
;; If there is a title string, take it, otherwise take the name.
;; The name is displayed only if title is t.
(let* ((str (if (typep title 'string) title name))
(n (length str)))
(add menu (format nil (make-title-string n) str) :y 0 :x 2))))
;; todo: when we refresh a window with a subwin, we shouldnt have to refresh the subwin separately.
;; make refresh specialize on menu and decorated window in a way to do both.
(refresh menu)))
(defmethod draw ((menu dialog-window))
;; first draw a menu
;; TODO: describe what exactly is drawn here and what in the parent method.
(call-next-method)
;; then draw the message in the reserved space above the menu.
(with-accessors ((message-text message-text) (message-height message-height)
(message-pad message-pad) (coords message-pad-coordinates)) menu
;; if there is text, and there is space reserved for the text, draw the text
(when (and message-text (> message-height 0))
(refresh message-pad
0 ;pad-min-y
0 ;pad-min-x
(first coords) ;screen-min-y
(second coords) ;screen-min-x
(third coords) ;screen-max-y
(fourth coords))))) ;screen-max-x
(defun reset-menu (menu)
"After the menu is closed reset it to its initial state."
(with-slots (items current-item-number current-item scrolled-region-start menu-type) menu
(setf current-item-number 0
current-item (car items)
scrolled-region-start (list 0 0))
(when (eq menu-type :checklist)
(loop for i in items if (checkedp i) do (setf (checkedp i) nil)))))
(defun return-from-menu (menu return-value)
"Set menu window to invisible, refresh the window stack, return the value from select."
(when *window-stack*
;; change visibility only when there is an active stack.
(typecase menu
(menu-window (setf (visiblep menu) nil))
(menu (setf (visiblep (window menu)) nil)))
(refresh-stack))
(reset-menu menu)
(throw menu return-value))
(defun exit-menu-event-loop (menu event)
"Associate this function with an event to exit the menu event loop."
(declare (ignore event))
(return-from-menu menu nil))
(defun checked-items (menu)
"Take a menu, return a list of checked menu items."
(loop for i in (items menu) if (checkedp i) collect i))
(defmethod value ((menu menu))
"Return the value of the selected item."
(value (current-item menu)))
(defmethod value ((checklist checklist))
"Return the list of values of the checked items."
(mapcar #'value (checked-items checklist)))
(defun accept-selection (menu event)
"Return the value of the currently selected item or all checked items."
(declare (ignore event))
(case (menu-type menu)
(:checklist
;; return all checked items (not their values) in the item list.
(return-from-menu menu (checked-items menu)))
(:selection
(let ((val (value (current-item menu))))
(cond
;; if the item is a string or symbol, just return it.
((or (typep val 'string)
(typep val 'symbol))
(return-from-menu menu val))
;; if the item is a function object, call it.
((typep val 'function)
(funcall val)
(return-from-menu menu (name (current-item menu))))
;; if the item is a menu (and thus also a menu-window), recursively select an item from that submenu
((or (typep val 'menu)
(typep val 'menu-window))
(let ((selected-item (select val)))
;; when we have more than menu in one window, redraw the parent menu when we return from the submenu.
(when (eq (type-of val) 'menu)
(draw menu))
(when selected-item
(return-from-menu menu selected-item)))) )))))
(defun update-redraw-menu (menu event)
"Update the menu after an event, the redraw the menu."
(update-menu menu event)
(draw menu))
(defun toggle-item-checkbox (menu event)
"Toggle the checked state of the current item, used in checkbox menus."
(declare (ignore event))
(setf (checkedp (current-item menu)) (not (checkedp (current-item menu))))
(draw menu))
;; all of these take two arguments: menu event
(define-keymap 'menu-map
(list
;; q doesnt return a value, just nil, i.e. in the case of a checklist, an empty list.
#\q 'exit-menu-event-loop
#\x 'toggle-item-checkbox
:up 'update-redraw-menu
:down 'update-redraw-menu
:left 'update-redraw-menu
:right 'update-redraw-menu
;; there is no :default action, all other events are ignored for menus.
;; return the selected item or all checked items, then exit the menu like q.
#\newline 'accept-selection))
(defun select (menu)
"Display the menu, let the user select an item, return the selected item.
If the item is a menu object, recursively display the sub menu."
(typecase menu
(menu-window
(when *window-stack*
(setf (visiblep menu) t)
(refresh-stack))
(draw menu)
;; here we can pass the menu to run-event-loop because it is a menu-window.
;; all handler functions have to accept window and event as arguments.
;; the return value of select is the return value of run-event-loop
;; is the value thrown to the catch tag 'event-loop.
(run-event-loop menu))
(menu
(draw menu)
(run-event-loop menu))))

89
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/mouse.lisp Normal file
View file

@ -0,0 +1,89 @@
(in-package :de.anvi.croatoan)
(defparameter *mouse-button-event-bitmask-alist*
'((:released . #o01)
(:pressed . #o02)
(:clicked . #o04)
(:double-clicked . #o10)
(:triple-clicked . #o20)
(:reserved-event . #o40)))
(defmacro mouse-bitmask (button event)
(let ((*mouse-button-event-bitmask-alist*
'((:released . #o01)
(:pressed . #o02)
(:clicked . #o04)
(:double-clicked . #o10)
(:triple-clicked . #o20)
(:reserved-event . #o40))))
(cond ((integerp event) `(ash ,event (* 6 (- ,button 1))))
((symbolp event)
(let ((mask (cdr (assoc event *mouse-button-event-bitmask-alist*))))
`(ash ,mask (* 6 (- ,button 1))))))))
(defparameter *mouse-event-bitmask-alist*
`((:button-1-released . ,(mouse-bitmask 1 :released))
(:button-1-pressed . ,(mouse-bitmask 1 :pressed))
(:button-1-clicked . ,(mouse-bitmask 1 :clicked))
(:button-1-double-clicked . ,(mouse-bitmask 1 :double-clicked))
(:button-1-triple-clicked . ,(mouse-bitmask 1 :triple-clicked))
(:button-1-reserved-event . ,(mouse-bitmask 1 :reserved-event))
(:button-2-released . ,(mouse-bitmask 2 :released))
(:button-2-pressed . ,(mouse-bitmask 2 :pressed))
(:button-2-clicked . ,(mouse-bitmask 2 :clicked))
(:button-2-double-clicked . ,(mouse-bitmask 2 :double-clicked))
(:button-2-triple-clicked . ,(mouse-bitmask 2 :triple-clicked))
(:button-2-reserved-event . ,(mouse-bitmask 2 :reserved-event))
(:button-3-released . ,(mouse-bitmask 3 :released))
(:button-3-pressed . ,(mouse-bitmask 3 :pressed))
(:button-3-clicked . ,(mouse-bitmask 3 :clicked))
(:button-3-double-clicked . ,(mouse-bitmask 3 :double-clicked))
(:button-3-triple-clicked . ,(mouse-bitmask 3 :triple-clicked))
(:button-3-reserved-event . ,(mouse-bitmask 3 :reserved-event))
(:button-4-released . ,(mouse-bitmask 4 :released))
(:button-4-pressed . ,(mouse-bitmask 4 :pressed))
(:button-4-clicked . ,(mouse-bitmask 4 :clicked))
(:button-4-double-clicked . ,(mouse-bitmask 4 :double-clicked))
(:button-4-triple-clicked . ,(mouse-bitmask 4 :triple-clicked))
(:button-4-reserved-event . ,(mouse-bitmask 4 :reserved-event))
(:button-ctrl . ,(mouse-bitmask 5 #o01))
(:button-shift . ,(mouse-bitmask 5 #o02))
(:button-alt . ,(mouse-bitmask 5 #o04))
(:report-mouse-position . ,(mouse-bitmask 5 #o10))))
;; (:all-mouse-events . ,(- (mouse-bitmask 5 #o10) 1)
;; take a unsigned long integer representing a bitmask of mouse events,
;; return a list of mouse event keywords.
(defun bitmask-to-keyword (bitmask)
(loop for i in (mapcar #'car *mouse-event-bitmask-alist*)
if (logtest bitmask (cdr (assoc i *mouse-event-bitmask-alist*))) return i))
;; use collect to catch more than 1 event at once.
;; (format scr "~32,'0b" bitmask)
(defun keyword-to-bitmask (keys)
"Take a list of mouse event keywords, return a logiored bitmask."
(apply #'logior (mapcar #'(lambda (x) (cdr (assoc x *mouse-event-bitmask-alist*)))
keys)))
(defun set-mouse-event (keyword-list)
"Take a list of mouse events, activate tracking of those events.
Returns an integer bitmask. An empty list turns off mouse tracking."
(%mousemask (keyword-to-bitmask keyword-list) (null-pointer)))
;; decode and return the mouse event struct as multiple values:
;; mouse event keyword, y coordinate integer, x coordinate integer
(defun get-mouse-event ()
(flet ((plist-symbols-to-keywords (plist)
;; mem-ref returns a struct as a symbol plist.
;; we have to convert the symbols to keywords to transport them across packages.
(loop for i in plist collect (if (symbolp i) (values (intern (symbol-name i) "KEYWORD")) i))))
(with-foreign-object (ptr '(:struct mevent))
(%getmouse ptr)
(let* ((struct (plist-symbols-to-keywords (mem-ref ptr '(:struct mevent))))
(x (getf struct :x))
(y (getf struct :y))
(b (getf struct :bstate))
(mouse-event (bitmask-to-keyword b)))
(values mouse-event y x)))))

32
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/move.lisp Normal file
View file

@ -0,0 +1,32 @@
(in-package :de.anvi.croatoan)
(defun move (window y x &key relative)
"Move cursor to the position given by row y and column x.
If relative is t, move the cursor by y rows and x columns."
(let ((winptr (winptr window)))
(if relative
(let ((pos-y (car (cursor-position window)))
(pos-x (cadr (cursor-position window))))
(%wmove winptr (+ pos-y y) (+ pos-x x)))
(%wmove winptr y x))))
(defun move-direction (window direction &optional (n 1))
"Move cursor in the given direction by n cells."
(case direction
(:left (move window 0 (* n -1) :relative t))
(:right (move window 0 (* n 1) :relative t))
(:up (move window (* n -1) 0 :relative t))
(:down (move window (* n 1) 0 :relative t))
(otherwise (error "Valid cursor movement directions: :left, :right, :up, :down"))))
(defun move-window (window y x &key relative)
"Move top left corner of the window to row y and column x.
If relative is t, move the window by y rows and x columns."
(let ((winptr (winptr window)))
(if relative
(let ((pos-y (car (location window)))
(pos-x (cadr (location window))))
(%mvwin winptr (+ pos-y y) (+ pos-x x)))
(%mvwin winptr y x))))

118
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/opaque.lisp Normal file
View file

@ -0,0 +1,118 @@
(in-package :croatoan)
;;; opaque
;;; curses window properties
;;; http://invisible-island.net/ncurses/man/curs_opaque.3x.html
;;; C prototypes
;; bool is_cleared(const WINDOW *win);
;; bool is_idcok(const WINDOW *win);
;; bool is_idlok(const WINDOW *win);
;; bool is_immedok(const WINDOW *win);
;; bool is_keypad(const WINDOW *win);
;; bool is_leaveok(const WINDOW *win);
;; bool is_nodelay(const WINDOW *win);
;; bool is_notimeout(const WINDOW *win);
;; bool is_pad(const WINDOW *win);
;; bool is_scrollok(const WINDOW *win);
;; bool is_subwin(const WINDOW *win);
;; bool is_syncok(const WINDOW *win);
;; WINDOW *wgetparent(const WINDOW *win);
;; int wgetscrreg(const WINDOW *win, int *top, int *bottom);
;;; Low-level C functions
(defcfun ("is_cleared" %is_cleared) :boolean (win window))
(defcfun ("is_idcok" %is_idcok) :boolean (win window))
(defcfun ("is_idlok" %is_idlok) :boolean (win window))
(defcfun ("is_immedok" %is_immedok) :boolean (win window))
(defcfun ("is_keypad" %is_keypad) :boolean (win window))
(defcfun ("is_leaveok" %is_leaveok) :boolean (win window))
(defcfun ("is_nodelay" %is_nodelay) :boolean (win window))
(defcfun ("is_notimeout" %is_notimeout) :boolean (win window))
(defcfun ("is_pad" %is_pad) :boolean (win window))
(defcfun ("is_scrollok" %is_scrollok) :boolean (win window))
(defcfun ("is_subwin" %is_subwin) :boolean (win window))
(defcfun ("is_syncok" %is_syncok) :boolean (win window))
(defcfun ("wgetparent" %wgetparent) window (win window))
(defcfun ("wgetscrreg" %wgetscrreg) :int (win window) (top (:pointer :int)) (bottom (:pointer :int)))
;;; High-level Lisp wrappers
(defun redraw-on-clear-p (window)
"If t, the next refresh will redraw the screen from scratch."
(%is_cleared window))
(defun insert-delete-char-p (window)
"If t, the hardware insert/delete char feature of a terminal will be used, if the terminal supports it."
(%is_idcok window))
(defun insert-delete-line-p (window)
"If t, the hardware insert/delete line feature of a terminal will be used, if the terminal supports it."
(is_idlok window))
(defun immediately-refresh-p (window)
"If t, any change to a window will automatically call refresh."
(%is_immedok window))
(defun function-keys-p (window)
"If t, function keys will be recognized when returned by get-char."
(%is_keypad window))
(defun leave-cursor-on-refresh-p (window)
"If t, don't move the cursor back to the position before refresh."
(%is_leaveok window))
;; Vorsicht: we don't use %nodelay for blocking settings. But maybe it still works somehow.
(defun input-blocking-p (window)
"If t, reading is blocking."
(not (%is_nodelay window)))
;; Hint: doesnt seem to work.
(defun escape-sequence-delay (window)
"If t, do not set a delay after the escape key."
(%is_notimeout window))
(defun pad-p (window)
"If t, the window is a pad."
(%is_pad window))
(defun enable-scrolling-p (window)
"If t, scrolling is enabled."
(%is_scrollok window))
(defun subwindow-p (window)
"If t, the window is a subwindow."
(%is_subwin window))
(defun touch-parent-windows-p (window)
"If t, areas in parent windows will be touched when window is changed."
(%is_syncok window))
(defun get-parent-window (window)
"If window is a subwindow, return its parent window."
(%wgetparent window))
(defun get-scrolling-region (window)
"Return a cons pair with the top and bottom margin of the scrolling region."
(let ((t-ptr (foreign-alloc :int))
(b-ptr (foreign-alloc :int)))
;; populate the pointers with values.
(%wgetscrreg window t-ptr b-ptr)
;; dereference the int pointers.
(let ((top (mem-ref t-ptr :int))
(bottom (mem-ref t-ptr :int)))
;; free the allocated memory.
(foreign-free t-ptr)
(foreign-free b-ptr)
;; return two color integers as a cons pair.
(cons top bottom))))
;;; TODOs
;;; NOTES
;; These functions which return properties set in the WINDOW
;; structure, allowing it to be compiled as opaque.

57
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/outopts.lisp Normal file
View file

@ -0,0 +1,57 @@
(in-package :croatoan)
;;; High-level Lisp wrappers
;; old bindings not yet replaced, deprecated, not exported, not loaded, do not use.
;; all defaults are FALSE
(defun redraw-on-clear (window flag)
"If flag is t, when refresh is called after clear, it will redraw the screen from scratch."
(%clearok window flag))
;; for now, to use clearok with curscr, use %clearok directly.
(defun insert-delete-line (window flag)
"If flag is t, use the hardware insert/delete line feature of a terminal, if the terminal supports it.
It is disabled by default."
(%idlok window flag))
(defun insert-delete-char (window flag)
"If flag is t, use the hardware insert/delete char feature of a terminal, if the terminal supports it.
It is enabled by default."
(%idcok window flag))
(defun immediately-refresh (window flag)
"If flag is t, any change to a window will automatically call refresh.
It is disabled by default, since it can degrade performance."
(%immedok window flag))
(defun leave-cursor-on-refresh (window flag)
"If flag is t, don't move the cursor back to the position before refresh.
It is disabled by default."
(%leaveok window flag))
(defun enable-scrolling (window flag)
"Enables and disables window scrolling.
If flag is t, when the curses moves below the bottom line of a window
or scrolling region, the window/region is scrolled.
If flag is nil, the cursor is left on the bottom line."
(%scrollok window flag))
(defun set-scrolling-region (window top-margin bottom-margin)
"Set the margins of a scrolling region for a window if scrolling is enabled for that window."
(%wsetscrreg window top-margin bottom-margin))
(defun newline-translation (flag)
"If status is t, enable translation of RET to NL on input, and NL to RET and LF on output.
It is enabled by default."
(if flag
(%nl)
(%nonl)))

321
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/package.lisp Normal file
View file

@ -0,0 +1,321 @@
(defpackage #:de.anvi.croatoan
(:documentation "High-level Lisp interface to the basic CFFI Ncurses API.")
(:use #:common-lisp #:cffi #:de.anvi.ncurses #:trivial-gray-streams)
(:shadow callback)
(:nicknames #:croatoan #:crt)
(:export
;; croatoan.lisp
with-screen
with-window
with-windows
event-case
keymap
define-keymap
find-keymap
run-event-loop
exit-event-loop
bind
unbind
save-excursion
;; classes
complex-char
complex-string
window
screen
sub-window
decorated-window
menu
checklist
menu-window
menu-item
dialog-window
pad
sub-pad
field
form
form-window
button
label
checkbox
shape
;; accessors
simple-char
attributes
color-pair
default-color-pair
fgcolor
bgcolor
complex-char-array
width
height
location
location-y
location-x
cursor-position
cursor-position-y
cursor-position-x
draw-border-p
stackedp
visiblep
winptr
input-blocking
frame-rate
function-keys-enabled-p
scrolling-enabled-p
scrolling-region
insert-mode-p
bindings
background
input-echoing-p
input-buffering-p
process-control-chars-p
newline-translation-enabled-p
cursor-visible-p
source-location
;; Predicates
closed-p
complex-char=
;; menu
items
menu-type
menu-location
current-item-number
current-item
current-item-mark
cyclic-selection-p
max-item-length
name
value
message-pad
message-text
message-height
message-pad-coordinates
menu-map
;; form
buffer
elements
style
max-buffer-length
callback
title
find-element
field-map
form-map
button-map
accept
cancel
reset-field
reset-form
checkedp
;; queue
submit
process
queue
job-error
enqueue
dequeue
;; shape
origin-x
origin-y
coordinates
plot-char
;; addch / add a character (with attributes) to a curses window, then advance the cursor
add
add-char
echo
echo-char
new-line
acs
wacs
;; add_wch / add a wide complex character to a curses window, then advance the cursor
add-wide-char
add-wide-char-utf-8
echo-wide-char
;; addstr / add a string of characters to a curses window and advance cursor
add-string
;; attr / curses character and window attribute control routines
*ansi-color-list*
convert-char
change-attributes
add-attributes
remove-attributes
;; beep / curses bell and screen flash routines
alert
;; bkgd / curses window background manipulation routines
;; border / create curses borders, horizontal and vertical lines
box
draw-border
;; border_set / create curses borders or lines using complex characters and renditions
draw-wide-border
;; clear / clear all or part of a curses window
clear
;; color / curses color manipulation routines
;; default_colors / use terminal's default colors
use-terminal-colors-p
;; define_key / define a keycode
;; delch / delete character under the cursor in a curses window
delete-char
;; deleteln / delete and insert lines in a curses window
delete-line
insert-line
;; form / curses extension for programming forms
remove-nth
replace-nth
insert-nth
edit
field-buffer-to-string
;; getch / get (or push back) characters from curses terminal keyboard
get-char
unget-char
key-supported-p
function-key
function-key-p
key-pressed-p
get-event
;; get_wch / get (or push back) a wide (multi-byte) character from curses terminal keyboard
get-wide-char
get-wide-event
;; getstr / accept character strings from curses terminal keyboard
get-string
;; getyx / get curses cursor and window coordinates
;; inch / get a character and attributes from a curses window
extract-char
;; in_wch / extract a wide character and rendition from a window
extract-wide-char
;; insch / insert a character before cursor in a curses window
insert
insert-char
;; ins_wch / insert a complex character and rendition into a window
insert-wide-char
;; instr / get a string of characters from a curses window
extract-string
;; inwstr / get a string of wide (multi-byte) characters from a curses window
extract-wide-string
;; inchstr / get a string of characters (and attributes) from a curses window
extract-complex-string
;; insstr / insert string before cursor in a curses window
insert-string
;; initscr / Screen initialization and manipulation routines
end-screen
;; inopts / Input options.
;; kernel / low-level curses routines
;; keybound / return definition of keycode
;; key_defined / check if a keycode is defined
;; legacy / get curses cursor and window coordinates, attributes
;; legacy_coding
;; menu / curses extension for programming menus
draw-menu
update-menu
select
return-from-menu
exit-menu-event-loop
accept-selection
update-redraw-menu
toggle-item-checkbox
;; mouse / mouse interface through curses
set-mouse-event
get-mouse-event
;; move / move curses window cursor
move
move-direction
move-window
;; opaque / curses window properties
;; outopts / curses output options
;; pad / create and display curses pads
;; panel / panel stack extension for curses
raise
raise-to-top
lower
lower-to-bottom
empty-stack
refresh-stack
;; refresh / refresh curses windows and lines
refresh
refresh-marked
mark-for-refresh
mark-for-redraw
;; resizeterm / change the curses terminal size
;; scroll / scroll a curses window
;; shape / shape plotting extension for ncurses
draw-shape
shape-extent
merge-shapes
fill-shape
line
angle-line
polygon
triangle
quadrilateral
rectangle
circle
;; slk / curses soft label routines
;; termattrs / environment query routines
;; touch / curses refresh control routines
touch
;; util / miscellaneous curses utility routines
;; variables / curses global variables
;; window / create curses windows
;; wresize / resize a curses window
resize
))

54
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/panel.lisp Normal file
View file

@ -0,0 +1,54 @@
(in-package :de.anvi.croatoan)
;; panel
;; panel stack extension for curses
;; http://invisible-island.net/ncurses/man/panel.3x.html
;; defined in source/classes.lisp
;; (defparameter *window-stack* nil)
(defun raise (win)
"Raise window one position in the stack."
(when (not (eq win (car *window-stack*)))
(let ((pos (position win *window-stack*)))
(rotatef (nth (1- pos) *window-stack*)
(nth pos *window-stack*)))))
(defun raise-to-top (win)
"Raise window to the top of the window stack."
(setf *window-stack* (cons win (remove win *window-stack*))))
(defun lower (win)
"Lower window one position in the stack."
(when (not (eq win (car (last *window-stack*))))
(let ((pos (position win *window-stack*)))
(rotatef (nth (1+ pos) *window-stack*)
(nth pos *window-stack*)))))
(defun lower-to-bottom (win)
"Lower window to the bottom of the window stack."
(when (not (eq win (car (last *window-stack*))))
(setf *window-stack* (append (remove win *window-stack*) (list win)))))
(defun empty-stack ()
"Remove all windows from the stack."
(setf *window-stack* nil))
(defun refresh-stack ()
"Touch and refresh visible windows in the window stack."
(if *window-stack*
(progn
(mapc #'(lambda (w)
(when (visiblep w)
(touch w)
(mark-for-refresh w)))
(reverse *window-stack*))
(refresh-marked))
(error "refresh stack: stack empty")))
;; https://www.informatimago.com/develop/lisp/l99/p19.lisp
;; todo: what if count is longer than a list? use mod
(defun rotate (list count)
(if (minusp count)
(rotate list (+ (length list) count))
(nconc (subseq list count) (subseq list 0 count))))

107
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/queue.lisp Normal file
View file

@ -0,0 +1,107 @@
(in-package :de.anvi.croatoan)
;; queue
;; support for cross-thread evaluation
;; authors: d4ryus <d4ryus@teknik.io>,
;; Anton Vidovic <anton.vidovic@gmx.de>
(defclass queue ()
((head
:documentation "Pointer to the first cons of the elements list.")
(tail
:documentation "Pointer to the last cons of the elements list.")
(lock
:documentation "A mutex that ensures thread-safe access to the queue from multiple threads."))
(:documentation "A thread-safe FIFO queue."))
(defmethod initialize-instance :after ((queue queue) &key)
(with-slots (head tail lock) queue
(setf head (cons nil nil)
tail (last head)
lock (bt:make-lock))))
(define-condition job-error (error)
((form
:initarg :form
:initform (error "Form required")
:documentation "The form that failed to execute")
(error
:initarg :error
:initform (error "Error required")
:documentation "The error that was signaled when form was executed")))
(defmethod print-object ((obj queue) stream)
(with-slots (head lock) obj
(bt:with-lock-held (lock)
(print-unreadable-object (obj stream :type t)
(format stream "~:[<empty>~;~:*~a~]" (cdr head))))))
(defmethod print-object ((obj job-error) stream)
(print-unreadable-object (obj stream :type t :identity t)
(with-slots (form error) obj
(format stream "form: ~a ~_error: ~a" form error))))
(defun enqueue (item queue)
"Push a new item onto the tail of the queue, return the new item."
(with-slots (tail lock) queue
(bt:with-lock-held (lock)
(car (setf tail (cdr (rplacd tail (list item))))))))
(defun dequeue (queue)
"Pop of the first element of queue and return it, returns NIL when queue is empty"
(with-slots (head lock) queue
(bt:with-lock-held (lock)
(when (cdr head)
(car (setf head (cdr head)))))))
(defparameter *job-queue* (make-instance 'queue)
"A queue of functions (consed to their form for debugging purposes)
to be processed by the main thread to interface with ncurses.")
(defmacro submit (&body body)
"Submit BODY from a producer thread to a job queue to be processed by the main thread.
The main thread should be the only one interfacing ncurses directly,
and should be running in a terminal.
SUBMIT uses a thread-safe FIFO queue to queue up jobs which should be
evaluated inside the terminal thread.
For this to work PROCESS has to be called from inside the terminal
thread to pop requests from the FIFO queue and evaluate them.
When a condition is signaled while the body of SUBMIT is evaluated, it
is handled by PROCESS and put inside a JOB-ERROR which also contains
the failed form.
The condition is then signaled again from within a restart which
allows skipping the failed form and continue evaluating requests.
In practice, this allows for calls to ncurses forms from SLIME to be
performed without IO glitches that tend to occur when ncurses code is
called from the SLIME repl thread directly."
`(enqueue
(cons (lambda () ,@body)
;; the failed form is included for debugging.
',body)
*job-queue*))
(defun process ()
"Process the contents of the job queue in the current thread, then exit.
Process should be called from the main thread, which should be the only thread
interfacing ncurses directly, and should be running in a terminal."
(loop :for (fn . form) := (dequeue *job-queue*)
:while fn
;; We want to be able to see what form failed, for this we
;; need to wrap the signaled condition in a job-error
;; which contains the failed form and the signaled condition.
:do (handler-case (funcall fn)
(error (e)
(restart-case (error 'job-error
:form form
:error e)
(skip-job-form ()
:report (lambda (stream)
(format stream "Skip job form"))))))))

56
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/refresh.lisp Normal file
View file

@ -0,0 +1,56 @@
(in-package :de.anvi.croatoan)
;; refresh windows _and_ pads
(defun refresh (win &optional pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x)
"Redisplay the window after changes have been made to it.
Copies a window to the virtual screen, then updates the visible
physical screen by the contents of the virtual screen.
Only updates the changed parts of the window. In order to redraw the
whole window, it has to be explicitely touched or marked for redraw."
(let ((winptr (winptr win)))
;; typease whether window or pad
;; if window, signal error if any parameters are provided.
;; if pad, signal error if not all parameters are provided.
;; typecase uses type-of or typep internally.
;; if typep, a pad will be recognized as a window, since it is a subclass.
;; the pad type has to be checked first.
(typecase win
(pad (progn
;; all 6 arguments have to be given, we dont have default arguments.
(unless (and pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x)
(error "One of the arguments for pad refreshing is missing."))
(%prefresh winptr pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x)))
(window (%wrefresh winptr)))))
;; call refresh-marked after this.
(defun mark-for-refresh (win &optional pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x)
"Mark a window for a later batch-refresh.
Copy a window to the virtual screen, but do not display it on the
visible physical screen. Call batch-refresh to display all marked
refreshes."
(let ((winptr (winptr win)))
;; typecase uses typep internally, so pad has to be checked first because it is a subclass of window.
(typecase win
(pad (progn
(unless (and pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x)
(error "One of the arguments for pad refreshing is missing."))
(%prefresh winptr pad-min-y pad-min-x screen-min-y screen-min-x screen-max-y screen-max-x)))
(window (%wnoutrefresh winptr)))))
;; call this after several windows have been marked for refresh.
(defun refresh-marked ()
"Refresh windows marked for refresh."
(%doupdate))
;; does not redraw, only marks for redrawing by refresh.
;; It assumes that the display on the terminal has been corrupted.
;; It is unclear how redrawwin differs from touchwin.
(defun mark-for-redraw (window &key first-line no-of-lines)
"Mark a whole window or a number of lines to be completely redrawn on the next refresh."
(let ((winptr (winptr window)))
(if (and first-line no-of-lines)
(%wredrawln winptr first-line no-of-lines)
(%redrawwin winptr))))

41
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/resizeterm.lisp Normal file
View file

@ -0,0 +1,41 @@
(in-package :croatoan)
;;; resizeterm
;;; change the curses terminal size
;;; http://invisible-island.net/ncurses/man/resizeterm.3x.html
;;; C prototypes
;; bool is_term_resized(int lines, int columns);
;; int resize_term(int lines, int columns);
;; int resizeterm(int lines, int columns);
;;; Low-level C functions
(defcfun ("is_term_resized" %is-term-resized) :boolean (lines :int) (columns :int))
(defcfun ("resize_term" %resize-term) :int (lines :int) (columns :int))
(defcfun ("resizeterm" %is-term-resized) :int (lines :int) (columns :int))
;;; High-level Lisp wrappers
(defun terminal-resized-p (height width)
"Returns t if resize-terminal would modify a window, and nil otherwise."
(%is-term-resized height width))
(defun resize-terminal (height width &key use-sigwinch-handler)
"Resizes the current window to the specified dimensions.
The function attempts to resize all windows. The areas that are
extended are filled with blanks.
It is not possible to resize pads without additional interaction with
the application.
If use-sigwinch-handler is t, add bookkeeping for the SIGWINCH
handler."
(if use-sigwinch-handler
(%resizeterm height width)
(%resize-term height width)))
;;; TODOs

30
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/scroll.lisp Normal file
View file

@ -0,0 +1,30 @@
(in-package :croatoan)
;;; scroll
;;; scroll a curses window
;;; http://invisible-island.net/ncurses/man/curs_scroll.3x.html
;;; C prototypes
;; int scroll(WINDOW *win);
;; int scrl(int n);
;; int wscrl(WINDOW *win, int n);
;;; Low-level C functions
(defcfun ("scroll" %scroll) :int (win window))
(defcfun ("scrl" %scrl) :int (n :int))
(defcfun ("wscrl" %wscrl) :int (win window) (n :int))
;;; High-level Lisp wrappers
(defun scroll (window &optional (n 1))
"Scroll the window for n lines.
If n is positive, scroll the window down. If n is negative, scroll the
window up. The cursor position is not changed."
(%wscrl n))
;;; TODOs
;; [ ] what about return values?

193
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/shape.lisp Normal file
View file

@ -0,0 +1,193 @@
(in-package :de.anvi.croatoan)
;; shapes
;; curses extension for plotting shapes
;; author: Daniel Vedder <daniel@terranostra.one>
(defclass shape ()
(;; TODO: merge -x and -y into one location in form of a list to correspond to the position/location slot of other elements.
(origin-x
:initform 0
:initarg :x0
:type integer
:accessor origin-x
:documentation "The x coordinate of this shape's point of origin.")
(origin-y
:initform 0
:initarg :y0
:type integer
:accessor origin-y
:documentation "The y coordinate of this shape's point of origin.")
;; Coordinates are stored as '(y x) pairs (note the order!)
(coordinates
:initform nil
:type (or null cons)
:accessor coordinates
:documentation "A list of coordinates relative to the origin that form this shape.")
(plot-char
:initform (make-instance 'complex-char :simple-char #\X :color-pair '(:white :black) :attributes nil)
:initarg :char
:type (or null character keyword complex-char)
:accessor plot-char
:documentation "The character to use for plotting."))
(:documentation "A shape is a list of coordinates, relative to an origin, that can be plotted in a window."))
;;; General shape methods
(defun shape-extent (shape)
"Return min-y, min-x, max-y, and max-x of a shape's coordinates as multiple values."
(let ((y-vals (mapcar #'first (coordinates shape)))
(x-vals (mapcar #'second (coordinates shape))))
(values (apply #'min y-vals) (apply #'min x-vals)
(apply #'max y-vals) (apply #'max x-vals))))
(defun fill-shape (shape)
"Take a shape that only shows the borders and 'color it out'."
;; Every point inside a shape has, on the same axis, a point larger and one smaller than itself.
(flet ((inside-p (pt shape)
(and (member pt (coordinates shape)
:test #'(lambda (p c) (and (= (first p) (first c))
(> (second p) (second c)))))
(member pt (coordinates shape)
:test #'(lambda (p c) (and (= (first p) (first c))
(< (second p) (second c)))))
(member pt (coordinates shape)
:test #'(lambda (p c) (and (= (second p) (second c))
(> (first p) (first c)))))
(member pt (coordinates shape)
:test #'(lambda (p c) (and (= (second p) (second c))
(< (first p) (first c))))))))
;; Iterate over the rectangle that encloses the shape, adding any
;; points inside the shape's borders to its coordinates
(do* ((extent (multiple-value-list (shape-extent shape)))
(min-y (first extent)) (min-x (second extent))
(max-y (third extent)) (max-x (fourth extent))
(y min-y (1+ y)))
((> y max-y) shape)
(do ((x min-x (1+ x)))
((> x max-x))
(when (inside-p (list y x) shape)
(setf (coordinates shape)
(append (coordinates shape) (list (list y x)))))))))
(defun merge-shapes (&rest shapes)
"Create a new shape object by merging the coordinates of a given list of shapes."
;; This keeps the first shape's point of origin and plot-char.
;; A completely new object is created and new lists consed up.
(let ((shp (make-instance 'shape
:char (plot-char (first shapes))
:y0 (origin-y (first shapes))
:x0 (origin-x (first shapes)))))
(dolist (s shapes shp)
(dolist (c (coordinates s))
(unless (member c (coordinates shp) :test #'equal)
(setf (coordinates shp)
(append (coordinates shp)
(list (list (first c) (second c))))))))))
;;; Create various basic shapes
(defun line (y0 x0 y1 x1 &key char)
"Return a straight line between two points"
;;make sure we're moving from left to right
(let (zx zy)
(when (or (> x0 x1) (and (= x0 x1) (> y0 y1)))
(setf zx x1 zy y1)
(setf x1 x0 y1 y0)
(setf x0 zx y0 zy)))
;;increment x from x0 to x1, building a list of coordinates as we go
(do* ((l (make-instance 'shape)) (coords nil)
(slope (if (= x0 x1) (abs (- y0 y1)) ;;prevent division-by-zero
(/ (- y1 y0) (- x1 x0))))
(x 0 (1+ x)) (y (round (* x slope)) (round (* x slope))))
((< x1 (+ x0 x)) ;;finalise the shape object and return it
(setf (coordinates l) coords)
(when char (setf (plot-char l) char))
l)
;;for each x value, figure out how many characters we need to print
;; in the y direction (depends on the slope gradient)
(do* ((next-x (+ x0 x)) (dy 0 (1+ dy))
(next-y (+ y0 y (if (plusp slope) dy (* -1 dy)))
(+ y0 y (if (plusp slope) dy (* -1 dy)))))
;;stop when we have stacked sufficient vertical coordinates
((or (and (>= 1 (abs slope)) (= dy 1)) ;;shallow slopes
(and (< 1 (abs slope)) (= dy (ceiling (abs slope)))) ;;steep
(if (plusp slope) ;;don't overshoot the end
(or (> next-y y1) (> next-x x1))
(or (< next-y y1) (> next-x x1)))))
;;append the next pair of coordinates
(setf coords (append coords (list (list next-y next-x)))))))
(defun angle-line (y0 x0 theta length &key char)
"Draw a line of the given length in the bearing theta from the origin."
;; theta = 0 -> vertically up; theta = 90 -> horizontally right
(let* ((radians (* pi (/ (- theta 90) 180.0)))
(y1 (+ y0 (* length (sin radians))))
(x1 (+ x0 (* length (cos radians)))))
(line y0 x0 (round y1) (round x1) :char char)))
(defun polygon (corners &key filled char)
"Return a polygon along a list of corners, optionally filled"
(do* ((pol (make-instance 'shape))
(i 0 (1+ i)) (j (1+ i) (1+ i)))
((= i (length corners))
(when char (setf (plot-char pol) char))
(if filled (fill-shape pol) pol))
(when (= j (length corners)) (setf j 0))
(setf pol (merge-shapes pol
(line (first (nth i corners)) (second (nth i corners))
(first (nth j corners)) (second (nth j corners))
:char char)))))
(defun triangle (y0 x0 y1 x1 y2 x2 &key filled char)
"Return a triangle (utility wrapper around `polygon')."
(polygon (list (list y0 x0) (list y1 x1) (list y2 x2))
:filled filled :char char))
(defun quadrilateral (y0 x0 y1 x1 y2 x2 y3 x3 &key filled char)
"Return a quadrilateral (utility wrapper around `polygon')."
(polygon (list (list y0 x0) (list y1 x1) (list y2 x2) (list y3 x3))
:filled filled :char char))
(defun rectangle (y0 x0 height width &key filled char)
"Return a rectangle (utility wrapper around `polygon')."
(polygon (list (list y0 x0) (list y0 (+ x0 (1- width)))
(list (+ y0 (1- height)) (+ x0 (1- width)))
(list (+ y0 (1- height)) x0))
:filled filled :char char))
(defun circle (y0 x0 radius &key filled char)
"Return a circle with a given radius, optionally filled."
(do* ((shp (make-instance 'shape)) (coords nil) (deg 0 (1+ deg))
(radians (* pi (/ deg 180.0)) (* pi (/ deg 180.0)))
(y (+ y0 (round (* radius (sin radians))))
(+ y0 (round (* radius (sin radians)))))
(x (+ x0 (round (* radius (cos radians))))
(+ x0 (round (* radius (cos radians)))))
(last-coord nil coord) (coord (list y x) (list y x)))
((= deg 360)
(setf (coordinates shp) coords)
(when char (setf (plot-char shp) char))
(if filled (fill-shape shp) shp))
(unless (equal coord last-coord)
(setf coords (append coords (list coord))))))
;;; Integrate shapes with the rest of croatoan
(defun draw-shape (window shape &optional squarify)
"Draw a shape in the given window."
;; If squarify is on, draw-shape doubles the width of the shape to compensate
;; for the fact that terminal fonts are higher than they are wide
(do* ((y0 (origin-y shape)) (x0 (origin-x shape)) (c (plot-char shape))
(coords (coordinates shape) (cdr coords))
(y (first (car coords)) (first (car coords)))
(x (second (car coords)) (second (car coords))))
((null coords))
(setf y (+ y0 y) x (+ x0 x))
(when squarify (setf x (* 2 x)))
(unless (or (minusp y) (minusp x) (>= y (height window)) (>= x (width window)))
(add window (simple-char c) :y y :x x :attributes (attributes c) :color-pair (color-pair c)))))

53
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/slk.lisp Normal file
View file

@ -0,0 +1,53 @@
(in-package :croatoan)
;;; slk
;;; curses soft label routines
;;; http://invisible-island.net/ncurses/man/curs_slk.3x.html
;;; C prototypes
;; int slk_init(int fmt);
;; int slk_set(int labnum, const char *label, int fmt);
;; int slk_refresh(void);
;; int slk_noutrefresh(void);
;; char *slk_label(int labnum);
;; int slk_clear(void);
;; int slk_restore(void);
;; int slk_touch(void);
;; int slk_attron(const chtype attrs);
;; int slk_attroff(const chtype attrs);
;; int slk_attrset(const chtype attrs);
;; int slk_attr_on(attr_t attrs, void *opts);
;; int slk_attr_off(const attr_t attrs, void *opts);
;; int slk_attr_set(const attr_t attrs, short color_pair, void *opts);
;; attr_t slk_attr(void);
;; int slk_color(short color_pair);
;; int slk_wset(int labnum, const wchar_t *label, int fmt);
;;; Low-level C functions
(defcfun ("slk_init" %slk-init) :int (fmt :int))
(defcfun ("slk_set" %slk-set) :int (labnum :int) (label :string) (fmt :int))
(defcfun ("slk_refresh" %slk-refresh) :int)
(defcfun ("slk_noutrefresh" %slk-noutrefresh) :int)
(defcfun ("slk_label" %slk-label) :string (labnum :int))
(defcfun ("slk_clear" %slk-clear) :int)
(defcfun ("slk_restore" %slk-restore) :int)
(defcfun ("slk_touch" %slk-touch) :int)
(defcfun ("slk_attron" %slk-attron) :int (attrs chtype))
(defcfun ("slk_attroff" %slk-attroff) :int (attrs chtype))
(defcfun ("slk_attrset" %slk-attrset) :int (attrs chtype))
(defcfun ("slk_attr_on" %slk-attr-on) :int (attrs attr) (opts (:pointer :void)))
(defcfun ("slk_attr_off" %slk-attr-off) :int (attrs attr) (opts (:pointer :void)))
(defcfun ("slk_attr_set" %slk-attr-set) :int (attrs attr) (color-pair :short) (opts (:pointer :void)))
(defcfun ("slk_attr" %slk-attr) attr)
(defcfun ("slk_color" %slk-color) :int (color-pair :short))
;;; High-level Lisp wrappers
;;; NOTES
;;; TODOs

37
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/termattrs.lisp Normal file
View file

@ -0,0 +1,37 @@
(in-package :croatoan)
;;; termattrs
;;; environment query routines
;;; http://invisible-island.net/ncurses/man/curs_termattrs.3x.html
;;; C prototypes
;; int baudrate(void);
;; char erasechar(void);
;; int erasewchar(wchar_t *ch);
;; bool has_ic(void);
;; bool has_il(void);
;; char killchar(void);
;; int killwchar(wchar_t *ch);
;; char *longname(void);
;; attr_t term_attrs(void);
;; chtype termattrs(void);
;; char *termname(void);
;;; Low-level C functions
(defcfun ("baudrate" %baudrate) :void)
(defcfun ("erasechar" %erasechar) :char)
(defcfun ("has_ic" %has_ic) :boolean)
(defcfun ("has_il" %has_il) :boolean)
(defcfun ("killchar" %killchar) :char)
(defcfun ("longname" %longname) :string)
(defcfun ("term_attrs" %term-attrs) attr)
(defcfun ("termattrs" %termattrs) chtype)
(defcfun ("termname" %termname) :string)
;;; High-level Lisp wrappers
;;; NOTES
;;; TODOs

13
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/touch.lisp Normal file
View file

@ -0,0 +1,13 @@
(in-package :de.anvi.croatoan)
(defun touch (window)
"Make the next call to refresh rewrite whe whole window by marking the whole window as changed.
Makes it possible to raise unchanged overlapping windows by refreshing."
(let ((winptr (winptr window)))
(%touchwin winptr)))
;;; TODOs
;; [ ] Return values, errors.
;; [ ] Difference to redrawwin.

350
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/utf8.lisp Normal file
View file

@ -0,0 +1,350 @@
(in-package :de.anvi.croatoan)
(defun ascii-byte-p (octet)
"Return t if octet is a single-byte 7-bit ASCII char.
The most significant bit is 0, so the allowed pattern is 0xxx xxxx."
(assert (typep octet 'integer))
(assert (<= (integer-length octet) 8))
(let ((bitmask #b10000000)
(template #b00000000))
;; bitwise and the with the bitmask #b11000000 to extract the first two bits.
;; check if the first two bits are equal to the template #b10000000.
(= (logand bitmask octet) template)))
(defun multi-byte-p (octet)
"Return t if octet is a part of a multi-byte UTF-8 sequence.
The multibyte pattern is 1xxx xxxx.
A multi-byte can be either a lead byte or a trail byte."
(assert (typep octet 'integer))
(assert (<= (integer-length octet) 8))
(let ((bitmask #b10000000)
(template #b10000000))
;; bitwise and the with the bitmask #b11000000 to extract the first two bits.
;; check if the first two bits are equal to the template #b10000000.
(= (logand bitmask octet) template)))
(defun lead-byte-p (octet)
"Return t if octet is one of the leading bytes of an UTF-8 sequence, nil otherwise.
Allowed leading byte patterns are 0xxx xxxx, 110x xxxx, 1110 xxxx and 1111 0xxx."
(assert (typep octet 'integer))
(assert (<= (integer-length octet) 8))
(let ((bitmasks (list #b10000000 #b11100000 #b11110000 #b11111000))
(templates (list #b00000000 #b11000000 #b11100000 #b11110000)))
(some #'(lambda (a b) (= (logand a octet) b)) bitmasks templates)))
;; http://stackoverflow.com/questions/14380143/matching-binary-patterns-in-c
(defun n-trail-bytes (octet)
"Take a leading utf-8 byte, return the number of continuation bytes 1-3."
(assert (typep octet 'integer))
(assert (<= (integer-length octet) 8))
(let ((bitmasks (list #b10000000 #b11100000 #b11110000 #b11111000))
(templates (list #b00000000 #b11000000 #b11100000 #b11110000)))
(loop for i from 0 to 3
when (= (nth i templates) (logand (nth i bitmasks) octet))
return i)))
(defun trail-byte-p (octet)
"Return t if octet is the continuation byte of an UTF-8 sequence.
The allowed continuation byte pattern is 10xx xxxx."
(assert (typep octet 'integer))
(assert (<= (integer-length octet) 8))
(let ((bitmask #b11000000)
(template #b10000000))
;; bitwise and the with the bitmask #b11000000 to extract the first two bits.
;; check if the first two bits are equal to the template #b10000000.
(= (logand bitmask octet) template)))
#|
Lower Upper Binary
bound bound Pattern
----------------------------------------------------
0x00000 0x00007F 0xxxxxxx
0x00080 0x0007FF 110xxxxx 10xxxxxx
0x00800 0x00FFFF 1110xxxx 10xxxxxx 10xxxxxx
0x10000 0x10FFFF 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
Unicode code points Range Encoding Binary value
------------------ -------- --------------------------
U+000000-U+00007f 0xxxxxxx 0xxxxxxx
U+000080-U+0007ff 110yyyxx 00000yyy xxxxxxxx
10xxxxxx
U+000800-U+00ffff 1110yyyy yyyyyyyy xxxxxxxx
10yyyyxx
10xxxxxx
U+010000-U+10ffff 11110zzz 000zzzzz yyyyyyyy xxxxxxxx
10zzyyyy
10yyyyxx
10xxxxxx
|#
;; two helper functions from the internal to the external format.
;; inside the app, we use lisp chars, we only convert from utf-8 on input and
;; to utf-8 on output.
(defun utf-8-to-unicode (byte-list)
"Take a list of one to four utf-8 encoded bytes (octets), return a code point.
Since this decoder will only used for reading keyboard input, the sequences are
not checked for illegal bytes.
Since security is not considered, this decoder should not be used for anything
else."
(let ((b1 (car byte-list)))
(cond ((ascii-byte-p b1) b1) ; if a single byte, just return it.
((multi-byte-p b1)
(if (lead-byte-p b1)
(let ((n (n-trail-bytes b1))
;; Content bits we want to extract from each lead byte.
(lead-templates (list #b01111111 #b00011111 #b00001111 #b00000111))
;; Content bits we want to extract from each trail byte.
(trail-template #b00111111))
(if (= n (1- (list-length byte-list)))
;; add lead byte
(+ (ash (logand (nth 0 byte-list) (nth n lead-templates)) (* 6 n))
;; and the trail bytes
(loop for i from 1 to n sum
(ash (logand (nth i byte-list) trail-template) (* 6 (- n i)))))
(error "calculated number of bytes doesnt match the length of the byte list")))
(error "first byte in the list isnt a lead byte"))))))
#|
(defun utf-8-to-unicode (byte-list)
"Take a list of one to four utf-8 encoded bytes (octets), return the shortest possible unicode code point."
(let ((b1 (car byte-list)))
(if (lead-byte-p b1)
(let ((n (n-trail-bytes b1)))
(if (= n (1- (list-length byte-list)))
(case n
;; if 0, we have simple ascii, so just get the char.
(0 b1)
;; if 1, we have to convert 110yyyxx 10xxxxxx to 00000yyyxxxxxxxx
(1 (+ (ash (logand (nth 0 byte-list) #b00011111) 6)
(ash (logand (nth 1 byte-list) #b00111111) 0)))
;; if 2, we have to convert 1110yyyy 10yyyyxx 10xxxxxx to yyyyyyyyxxxxxxxx
(2 (+ (ash (logand (nth 0 byte-list) #b00001111) 12)
(ash (logand (nth 1 byte-list) #b00111111) 6)
(ash (logand (nth 2 byte-list) #b00111111) 0)))
;; if 3, we have to convert 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx to 000zzzzz yyyyyyyy xxxxxxxx
(3 (+ (ash (logand (nth 0 byte-list) #b00000111) 18)
(ash (logand (nth 1 byte-list) #b00111111) 12)
(ash (logand (nth 2 byte-list) #b00111111) 6)
(ash (logand (nth 3 byte-list) #b00111111) 0))))
(error "calculated number of bytes doesnt match the length of the byte list")))
(error "first byte in the list isnt a lead byte"))))
|#
#|
;; we also can determine the number of required bytes by the bit-length of the code point.
(n-bits (integer-length int))
(n-trail-bytes (cond ( (<= n-bits 7) 0)
((and (> n-bits 7) (<= n-bits 11)) 1)
((and (> n-bits 11) (<= n-bits 16)) 2)
((and (> n-bits 16) (<= n-bits 21)) 3)))
|#
;; we can also just print the char to a string, and output the string.
;; this is easier than utf-8 single char input.
(defun unicode-to-utf-8 (int)
"Take a unicode code point, return a list of one to four UTF-8 encoded bytes (octets)."
(assert (<= (integer-length int) 21))
(let ((n-trail-bytes (cond ((<= #x00000 int #x00007F) 0)
((<= #x00080 int #x0007FF) 1)
((<= #x00800 int #x00FFFF) 2)
((<= #x10000 int #x10FFFF) 3)))
(lead-templates (list #b00000000 #b11000000 #b11100000 #b11110000))
(trail-template #b10000000)
;; number of content bits in the lead byte.
(n-lead-bits (list 7 5 4 3))
;; number of content bits in the trail byte.
(n-trail-bits 6)
;; list to put the UTF-8 encoded bytes in.
(byte-list nil))
(if (= n-trail-bytes 0)
;; if we need 0 trail bytes, ist just an ascii single byte.
(push int byte-list)
(progn
;; if we need more than one byte, first fill the trail bytes with 6 bits each.
(loop for i from 0 to (1- n-trail-bytes)
do (push (+ trail-template
(ldb (byte n-trail-bits (* i n-trail-bits)) int))
byte-list))
;; then copy the remaining content bytes to the lead byte.
(push (+ (nth n-trail-bytes lead-templates)
(ldb (byte (nth n-trail-bytes n-lead-bits) (* n-trail-bytes n-trail-bits)) int))
byte-list)))
;; return the list of UTF-8 encoded bytes.
byte-list))
#|
;; %wgetch returns chars <255 and keycodes >255.
;; %wget_wch returns wide chars <255 and >255, and keycodes >255.
;; it also returns KEY_CODE_YES to designate that a >255 char is a keycode.
(defun get-char- (window &key y x)
""
(let* ((winptr (winptr window))
(byte-list nil)
;; get the first byte
(b1 (%wgetch winptr)))
;; -1 means "no event", >255 means function key.
;; TODO: problem, when we return b1>255, how do we know that it is a function key and not a unicode code point??
;; we have to return function keywords _before_ we assemble a code point from utf-8.
;; we have to merge get-char and get-event.
(when (= b1 -1) (return-from get-char- (values b1 nil)))
(when (> b1 255) (return-from get-char- (values b1 t)))
;; normal 8-bit octets in the range 0-255.
(if (lead-byte-p b1)
(progn
(push b1 byte-list)
;;(princ b1 window)
(let ((n (n-trail-bytes b1)))
(loop repeat n do
(let ((ch (%wgetch winptr)))
;;(princ ch window)
(push ch byte-list)))))
(error "First byte isnt a lead byte."))
;;(princ (utf-8-to-unicode (reverse byte-list)) window)
(values (utf-8-to-unicode (reverse byte-list)) nil)))
(defun get-event- (window)
(multiple-value-bind (code-point function-key-p) (get-char window)
(cond
;; -1 means no key has been pressed.
((= code-point -1) nil)
;; 0-255 are regular chars, whch can be converted to lisp chars with code-char.
((and (>= code-point 0) (not function-key-p)) (code-char code-point))
;; if the code belongs to a known function key, return a keyword symbol.
((and (>= code-point 0) function-key-p)
(let ((ev (function-key code-point)))
(if (eq ev :mouse)
(multiple-value-bind (mev y x) (get-mouse-event)
(values mev y x)) ; returns 3 values, see mouse.lisp
ev)))
;; todo: unknown codes, like mose, resize and unknown function keys.
(t (error "invalid value of char received from ncurses.")))))
|#
;; return t if the chosen unicode points are encoded and decoded correctly.
(defun test-utf-8 ()
(let* ((unicodes-orig (list 65 246 1046 8364 119070))
(unicodes-test (mapcar #'(lambda (x) (utf-8-to-unicode (unicode-to-utf-8 x)))
unicodes-orig)))
(mapcar #'(lambda (x)
(format t
"code point: ~A, character ~A, utf8 ~A, correct enc-dec ~A~%"
x
(code-char x)
(unicode-to-utf-8 x)
(= x (utf-8-to-unicode (unicode-to-utf-8 x)))))
unicodes-orig)
;; return t if all are t
(every #'= unicodes-orig unicodes-test)))
;; reading utf-8 chars from the keyboard works.
;; tested in t03.
;; to make t16c work too, we have to similarly be able to extract utf-8 from a window.
;; characters are saved by ncurses as wchar_t or wint_t.
;; instead of get-char, use read-byte and gray streams
;; part 2 will be correctly implementing get_wch und winwch.
;; then we do not need utf-8 conversion.
;; read one (first) char from the stream
;; check how many chars we have to read if it is an utf8 char
;; read additional n (0-3) octets.
;; combine 1-4 octets into one lisp utf-8 char and return that char.
;; all bytes here are octets.
#|
(defun get-utf-8-char (byte-list)
"Take a list of chars, return the first UTF-8 encoded char.
Signal an error if there are malformatted octets before the first char
is successfully read."
(let ((one-char-list nil)
(b1 (car byte-list)))
(if (lead-byte-p b1)
(progn
(push b1 one-char-list)
(let ((n (n-trail-bytes b1)))
(loop for i from 1 to n do (push (nth i byte-list) one-char-list))))
(error "First byte isnt a lead byte."))
(reverse one-char-list)))
|#
;; (code-char (utf-8-to-unicode (bytes))) => #\a
;; char-code and code-char translate between lisp chars and unicode code points.
;; so we have to return wchar_t compatible 32-bit integers.
#|
;; instead of stream, we have to use window as an argument here.
(defun get-utf-8-char (stream)
(let ((bytes nil)
(ch (get-char window)))
;; check whether single-byte or multi-byte.
;; if single-byte: return ch
;; if multi-byte: read continuation bytes, combine bytes, return ch
(if (lead-byte-p ch)
(let ((n (n-trail-bytes ch)))
(if (= n 0)
(push ch bytes)
(loop repeat n do (push (get-char window)))))
(error "trail byte without lead byte"))))
|#
#|
(defun utf-8-number-of-bytes (first-byte)
"returns the length of the utf-8 code in number of bytes, based on the first byte.
The length can be a number between 1 and 4."
(declare (fixnum first-byte))
(cond ((= 0 (ldb (byte 1 7) first-byte)) 1)
((= #b110 (ldb (byte 3 5) first-byte)) 2)
((= #b1110 (ldb (byte 4 4) first-byte)) 3)
((= #b11110 (ldb (byte 5 3) first-byte)) 4)
(t (error "unknown number of utf-8 bytes for ~a" first-byte))))
(defun utf-8-decode-unicode-character-code-from-stream (stream)
"Decodes byte values, from a binary byte stream, which describe a character
encoded using UTF-8.
Returns the character code and the number of bytes read."
(let* ((first-byte (read-byte stream))
(number-of-bytes (utf-8-number-of-bytes first-byte)))
(declare (fixnum first-byte number-of-bytes))
(ecase number-of-bytes
(1 (values (ldb (byte 7 0) first-byte)
1))
(2 (values (logior (ash (ldb (byte 5 0) first-byte) 6)
(ldb (byte 6 0) (read-byte stream)))
2))
(3 (values (logior (ash (ldb (byte 5 0) first-byte) 12)
(ash (ldb (byte 6 0) (read-byte stream)) 6)
(ldb (byte 6 0) (read-byte stream)))
3))
(4 (values (logior (ash (ldb (byte 3 0) first-byte) 18)
(ash (ldb (byte 6 0) (read-byte stream)) 12)
(ash (ldb (byte 6 0) (read-byte stream)) 6)
(ldb (byte 6 0) (read-byte stream)))
4))
(t (error "wrong UTF-8 encoding for file position ~a of stream ~s"
(file-position stream)
stream)))))
(mapcar #'(lambda (x) (princ (code-char (utf-8-to-unicode (unicode-to-utf-8 x))))) (list 65 246 1046 8364 119070))
=> (#\A #\LATIN_SMALL_LETTER_O_WITH_DIAERESIS #\CYRILLIC_CAPITAL_LETTER_ZHE #\EURO_SIGN #\MUSICAL_SYMBOL_G_CLEF)
|#

52
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/util.lisp Normal file
View file

@ -0,0 +1,52 @@
(in-package :croatoan)
;;; util
;;; miscellaneous curses utility routines
;;; http://invisible-island.net/ncurses/man/curs_util.3x.html
;;; C prototypes
;; char *unctrl(chtype c);
;; wchar_t *wunctrl(cchar_t *c);
;; char *keyname(int c);
;; char *key_name(wchar_t w);
;; void filter(void);
;; void nofilter(void);
;; void use_env(bool f);
;; int putwin(WINDOW *win, FILE *filep);
;; WINDOW *getwin(FILE *filep);
;; int delay_output(int ms);
;; int flushinp(void);
;;; Low-level C functions
(defcfun ("unctrl" %unctrl) :string (c chtype))
(defcfun ("keyname" %keyname) :string (c :int))
(defcfun ("filter" %filter) :void)
(defcfun ("nofilter" %nofilter) :void)
(defcfun ("use-env" %use-env) :void (f :boolean))
(defcfun ("delay_output" %delay-output) :int (ms :int))
(defcfun ("flushinp" %flushinp) :int)
;;; High-level Lisp wrappers
(defun char-to-string (char)
"Return a string representing the char."
(%unctrl char))
(defun key-to-string (key)
"Return a string representing they key."
(%keyname key))
;;; NOTES
;; Also see %use-legacy-coding in legacy_coding.lisp.
;;; TODOs
;; [ ] putwin, getwin, FILE pointer.
;; [ ] wunctrl, key_name, for wide chars.

62
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/variables.lisp Normal file
View file

@ -0,0 +1,62 @@
(in-package :croatoan)
;;; variables
;;; curses global variables
;;; http://invisible-island.net/ncurses/man/curs_variables.3x.html
;;; http://h71000.www7.hp.com/doc/83final/5763/5763pro_016.html
;;; Low-level C global variables
;; int COLOR_PAIRS;
;; int COLORS;
;; int COLS;
;; int ESCDELAY;
;; int LINES;
;; int TABSIZE;
;; WINDOW * curscr;
;; WINDOW * newscr;
;; WINDOW * stdscr;
;;; Lisp read-only global constants.
(defcvar ("COLOR_PAIRS" +color-pairs+ :read-only t) :int
"Number of color pairs which the terminal can support.")
(defcvar ("COLORS" +colors+ :read-only t) :int
"Number of colors which the terminal can support.")
(defcvar ("COLS" +screen-columns+ :read-only t) :int
"Width of the screen, the number of columns.")
(defcvar ("ESCDELAY" +esc-delay+ :read-only t) :int
"Number of miliseconds to wait after reading an escape character,
to distinguish between an individual escape character entered on the
keyboard from escape sequences sent by cursor- and function-keys.")
(defcvar ("LINES" +screen-lines+ :read-only t) :int
"Height of the screen, the number of lines.")
(defcvar ("TABSIZE" +tab-size+ :read-only t) :int
"Number of columns to convert a tab character to spaces when
displaying the tab in a window.")
#|
curscr is the contents of the physical display screen, so it naturally
includes the ripped-off lines.
6.3.1 Predefined Windows (stdscr and curscr)
Initially, two windows the size of the terminal screen are predefined
by Curses. These windows are called stdscr and curscr . The stdscr
window is defined for your use. Many Curses macros default to this
window.
The second predefined window, curscr , is designed for internal Curses
work; it is an image of what is currently displayed on the terminal
screen. The only HP C for OpenVMS Curses function that will accept
this window as an argument is clearok . Do not write to or read from
curscr . Use stdscr and user-defined windows for all your Curses
applications.
|#

39
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/window.lisp Normal file
View file

@ -0,0 +1,39 @@
(in-package :de.anvi.croatoan)
;; takes integers and returns a winptr.
(defun new-window (&key height width begin-y begin-x)
(%newwin height width begin-y begin-x))
;; Example: (new-window :height 18 :width 17 :begin-y 4 :begin-x 19)
;; TODO: one single command to delete a window and to end screen, or better a method that specializes on window type.
;; takes a window object.
;; TODO: look up what delwin returns.
(defun delete-window (window)
(%delwin (winptr window)))
;; takes a winptr.
(defun move-window (window y x)
(%mvwin window y x))
;; takes a winptr, returns a winptr.
(defun new-subwindow (parent-window &key height width begin-y begin-x relative)
(if relative
(%derwin parent-window height width begin-y begin-x)
(%subwin parent-window height width begin-y begin-x)))
;; This is NOT a move function, despite the name. You still move a subwindow with mvwin.
;; "Moving subwindows is allowed, but should be avoided."
;; mvderwin changes the source area of a subwin, but not the output area.
;; "This routine is used to display different parts of the parent window at the same physical position on the screen."
(defun move-subwindow (window parent-y parent-x)
(%mvderwin window parent-y parent-x))
(defun duplicate-window (window)
(%dupwin window))
;;; TODOs
;; Do something with wsyncup, syncok, wcursyncup, wsyncdown.
;; For now, I wont wrap them, because I have no idea how to test them.
;; I doubt anybody will ever use them.

5
sbcl/.quicklisp/dists/quicklisp/software/croatoan-20191227-git/src/wresize.lisp Normal file
View file

@ -0,0 +1,5 @@
(in-package :de.anvi.croatoan)
(defun resize (window height width)
(let ((winptr (winptr window)))
(%wresize winptr height width)))