# HG changeset patch # User Steve Losh # Date 1472253546 0 # Node ID 8a0871a52d1d40eef71356f094632232bed0af07 # Parent 8f91275f1233c7b3b2430be7e6fd22cc5227b325 More random playing diff -r 8f91275f1233 -r 8a0871a52d1d package.lisp --- a/package.lisp Tue Aug 23 21:59:37 2016 +0000 +++ b/package.lisp Fri Aug 26 23:19:06 2016 +0000 @@ -125,3 +125,15 @@ #:sand.utils) (:export )) + +(defpackage #:sand.ffi + (:use + #:sb-alien + #:cl + #:cl-arrows + #:losh + #:iterate + #:sand.quickutils + #:sand.utils) + (:export + )) diff -r 8f91275f1233 -r 8a0871a52d1d sand.asd --- a/sand.asd Tue Aug 23 21:59:37 2016 +0000 +++ b/sand.asd Fri Aug 26 23:19:06 2016 +0000 @@ -39,6 +39,7 @@ (:file "ascii") (:file "markov") (:file "dijkstra-maps") + (:file "ffi") (:file "binary-decision-diagrams") (:file "huffman-trees") (:module "terrain" diff -r 8f91275f1233 -r 8a0871a52d1d src/ascii.lisp --- a/src/ascii.lisp Tue Aug 23 21:59:37 2016 +0000 +++ b/src/ascii.lisp Fri Aug 26 23:19:06 2016 +0000 @@ -8,12 +8,99 @@ (defparameter *width* 1) (defparameter *height* 1) + +;;;; Color -------------------------------------------------------------------- +(defmethod print-object ((object hash-table) stream) + (let* ((keys (hash-table-keys object)) + (vals (hash-table-values object)) + (count (hash-table-count object)) + (key-width (-<> keys + (mapcar (compose #'length #'prin1-to-string) <>) + (reduce #'max <> :initial-value 0) + (clamp 0 20 <>)))) + (print-unreadable-object (object stream :type t :identity nil) + (format stream ":test ~A :count ~D {~%~{~{ ~vs ~s~}~%~}}" + (hash-table-test object) + count + (loop + :with limit = 40 + :for key :in keys + :for val :in vals + :for i :from 0 :to limit + :collect (if (= i limit) + (list key-width 'too-many-items (list (- count i) 'more)) + (list key-width key val))))))) + + +(defvar *colors* (make-hash-table)) +(defvar *color-pairs* (make-hash-table)) +(defvar *color-pair-counter* 100) + +(defun initialize-color () + (charms/ll:start-color) + (clrhash *color-pairs*) + (setf *color-pair-counter* 100) + (iterate + (for (nil (number r g b)) :in-hashtable *colors*) + (charms/ll:init-color number r g b))) + + + +(defun color-content (color-index) + (cffi:with-foreign-objects ((r :short) (g :short) (b :short)) + (charms/ll:color-content 1 r g b) + (list (cffi:mem-ref r :short) + (cffi:mem-ref g :short) + (cffi:mem-ref b :short)))) + +(defmacro with-attr (attr &body body) + `(prog2 + (charms/ll:attron ,attr) + (progn ,@body) + (charms/ll:attroff ,attr))) + + +(defun define-color (name number r g b) + (flet ((conv (fl) + (clamp 0 999 (truncate (* 1000 fl))))) + (setf (gethash name *colors*) + (list number (conv r) (conv g) (conv b))) + (clrhash *color-pairs*) ; fuck it + t)) + +(define-color :black 100 0 0 0) +(define-color :lavender 101 0.733 0.549 0.757) +(define-color :peach 102 0.831 0.537 0.416) +(define-color :red 103 1 0 0) + +(defun setup-color-pair (fg bg) + (let ((pair-id (incf *color-pair-counter*))) + (charms/ll:init-pair pair-id + (first (gethash fg *colors*)) + (first (gethash bg *colors*))) + pair-id)) + +(defun retrieve-color-pair (fg bg) + (-<> *color-pairs* + (ensure-gethash bg <> (make-hash-table)) + (ensure-gethash fg <> (setup-color-pair fg bg)) + (charms/ll:color-pair <>))) + +(defmacro with-color ((fg bg) &body body) + `(with-attr (retrieve-color-pair ,fg ,bg) + ,@body)) + (defun render () + (with-color (:red :red) + (charms:write-string-at-point charms:*standard-window* + "KINGBREAKER" + 10 8)) (charms:move-cursor charms:*standard-window* (getf *ball* :x) (getf *ball* :y)) (charms:write-char-at-cursor charms:*standard-window* #\o) - (charms:move-cursor charms:*standard-window* 0 0)) + (charms:move-cursor charms:*standard-window* 0 0) + ) (defun tick () @@ -40,6 +127,7 @@ (charms:disable-echoing) (charms:enable-raw-input :interpret-control-characters t) (charms:enable-non-blocking-mode charms:*standard-window*) + (initialize-color) (iterate (while *running*) @@ -49,7 +137,8 @@ (tick) (render) (charms:refresh-window charms:*standard-window*) - (sleep 0.03)))) + (sleep 0.1)))) ; (run) + diff -r 8f91275f1233 -r 8a0871a52d1d src/ffi.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/ffi.lisp Fri Aug 26 23:19:06 2016 +0000 @@ -0,0 +1,45 @@ +(in-package #:sand.ffi) + +(define-alien-routine ("strlen" c-str-len) size-t + (s c-string :in)) + +(define-alien-routine ("hypot" hypotenuse) double + (x double :in) + (y double :in)) + +(define-alien-routine ("strchr" string-char) c-string + (s c-string) + (c int)) + +(declaim (inline is-upper)) +(define-alien-routine ("isupper" is-upper) int + (ch int)) + +(defun uppercasep (character) + (not (zerop (is-upper (char-code character))))) + +(c-str-len "Hello!") +(load-shared-object "~/src/linenoise/linenoise.dylib") + +(define-alien-routine linenoise c-string + (prompt c-string)) + +(define-alien-routine + ("linenoiseHistorySetMaxLen" linenoise-history-set-max-len) + int + (max-length int)) + +(define-alien-routine ("linenoiseHistoryAdd" linenoise-history-add) int + (string c-string)) + +(define-alien-routine ("linenoiseClearScreen" linenoise-clear-screen) void) + + + +(linenoise-history-set-max-len 10) +(linenoise-history-add "Alice") +(linenoise-history-add "Bob") +(iterate (for i :from 0 :to 20) + (linenoise-history-add (format nil "history entry ~d" i))) +(linenoise "? ") + diff -r 8f91275f1233 -r 8a0871a52d1d src/markov.lisp --- a/src/markov.lisp Tue Aug 23 21:59:37 2016 +0000 +++ b/src/markov.lisp Fri Aug 26 23:19:06 2016 +0000 @@ -1,7 +1,7 @@ (in-package #:sand.markov) -(defparameter *text* - (read-file-into-string "data/lightships-and-lighthouses.txt")) +; (defparameter *text* +; (read-file-into-string "data/lightships-and-lighthouses.txt")) (defclass markov () ((database :initarg :database :accessor markov-database) diff -r 8f91275f1233 -r 8a0871a52d1d vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Tue Aug 23 21:59:37 2016 +0000 +++ b/vendor/make-quickutils.lisp Fri Aug 26 23:19:06 2016 +0000 @@ -3,24 +3,23 @@ (qtlc:save-utils-as "quickutils.lisp" :utilities '( - :with-gensyms - :once-only + :compose :curry - :rcurry + :define-constant + :ensure-gethash + :hash-table-alist + :hash-table-plist + :hash-table-keys + :hash-table-values :n-grams - :define-constant + :once-only + :rcurry + :read-file-into-string + :required-argument :riffle :tree-collect - :ensure-gethash - :required-argument - :read-file-into-string - :hash-table-alist - :hash-table-plist - ; :switch - ; :while - ; :ensure-boolean - ; :iota - ; :zip + :with-gensyms + ) :package "SAND.QUICKUTILS") diff -r 8f91275f1233 -r 8a0871a52d1d vendor/quickutils.lisp --- a/vendor/quickutils.lisp Tue Aug 23 21:59:37 2016 +0000 +++ b/vendor/quickutils.lisp Fri Aug 26 23:19:06 2016 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :N-GRAMS :DEFINE-CONSTANT :RIFFLE :TREE-COLLECT :ENSURE-GETHASH :REQUIRED-ARGUMENT :READ-FILE-INTO-STRING :HASH-TABLE-ALIST :HASH-TABLE-PLIST) :ensure-package T :package "SAND.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :DEFINE-CONSTANT :ENSURE-GETHASH :HASH-TABLE-ALIST :HASH-TABLE-PLIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :N-GRAMS :ONCE-ONLY :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :TREE-COLLECT :WITH-GENSYMS) :ensure-package T :package "SAND.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "SAND.QUICKUTILS") @@ -13,59 +13,18 @@ (in-package "SAND.QUICKUTILS") (when (boundp '*utilities*) - (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS - :MAKE-GENSYM-LIST :ONCE-ONLY - :ENSURE-FUNCTION :COMPOSE :CURRY - :RCURRY :TAKE :N-GRAMS - :DEFINE-CONSTANT :RIFFLE :TREE-COLLECT - :ENSURE-GETHASH :REQUIRED-ARGUMENT - :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE + (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION + :COMPOSE :CURRY :DEFINE-CONSTANT + :ENSURE-GETHASH :HASH-TABLE-ALIST + :HASH-TABLE-PLIST :MAPHASH-KEYS + :HASH-TABLE-KEYS :MAPHASH-VALUES + :HASH-TABLE-VALUES :TAKE :N-GRAMS + :ONCE-ONLY :RCURRY :WITH-OPEN-FILE* + :WITH-INPUT-FROM-FILE :READ-FILE-INTO-STRING - :HASH-TABLE-ALIST :HASH-TABLE-PLIST)))) - - (deftype string-designator () - "A string designator type. A string designator is either a string, a symbol, -or a character." - `(or symbol string character)) - - - (defmacro with-gensyms (names &body forms) - "Binds each variable named by a symbol in `names` to a unique symbol around -`forms`. Each of `names` must either be either a symbol, or of the form: - - (symbol string-designator) - -Bare symbols appearing in `names` are equivalent to: - - (symbol symbol) - -The string-designator is used as the argument to `gensym` when constructing the -unique symbol the named variable will be bound to." - `(let ,(mapcar (lambda (name) - (multiple-value-bind (symbol string) - (etypecase name - (symbol - (values name (symbol-name name))) - ((cons symbol (cons string-designator null)) - (values (first name) (string (second name))))) - `(,symbol (gensym ,string)))) - names) - ,@forms)) - - (defmacro with-unique-names (names &body forms) - "Binds each variable named by a symbol in `names` to a unique symbol around -`forms`. Each of `names` must either be either a symbol, or of the form: - - (symbol string-designator) - -Bare symbols appearing in `names` are equivalent to: - - (symbol symbol) - -The string-designator is used as the argument to `gensym` when constructing the -unique symbol the named variable will be bound to." - `(with-gensyms ,names ,@forms)) - + :REQUIRED-ARGUMENT :RIFFLE + :TREE-COLLECT :STRING-DESIGNATOR + :WITH-GENSYMS)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-gensym-list (length &optional (x "G")) "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`, @@ -74,45 +33,6 @@ (loop repeat length collect (gensym g)))) ) ; eval-when - - (defmacro once-only (specs &body forms) - "Evaluates `forms` with symbols specified in `specs` rebound to temporary -variables, ensuring that each initform is evaluated only once. - -Each of `specs` must either be a symbol naming the variable to be rebound, or of -the form: - - (symbol initform) - -Bare symbols in `specs` are equivalent to - - (symbol symbol) - -Example: - - (defmacro cons1 (x) (once-only (x) `(cons ,x ,x))) - (let ((y 0)) (cons1 (incf y))) => (1 . 1)" - (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) - (names-and-forms (mapcar (lambda (spec) - (etypecase spec - (list - (destructuring-bind (name form) spec - (cons name form))) - (symbol - (cons spec spec)))) - specs))) - ;; bind in user-macro - `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) - gensyms names-and-forms) - ;; bind in final expansion - `(let (,,@(mapcar (lambda (g n) - ``(,,g ,,(cdr n))) - gensyms names-and-forms)) - ;; bind in user-macro - ,(let ,(mapcar (lambda (n g) (list (car n) g)) - names-and-forms gensyms) - ,@forms))))) - (eval-when (:compile-toplevel :load-toplevel :execute) ;;; To propagate return type and allow the compiler to eliminate the IF when ;;; it is known if the argument is function or not. @@ -178,37 +98,6 @@ (apply ,fun ,@curries more))))) - (defun rcurry (function &rest arguments) - "Returns a function that applies the arguments it is called -with and `arguments` to `function`." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (let ((fn (ensure-function function))) - (lambda (&rest more) - (declare (dynamic-extent more)) - (multiple-value-call fn (values-list more) (values-list arguments))))) - - - (defun take (n sequence) - "Take the first `n` elements from `sequence`." - (subseq sequence 0 n)) - - - (defun n-grams (n sequence) - "Find all `n`-grams of the sequence `sequence`." - (assert (and (plusp n) - (<= n (length sequence)))) - - (etypecase sequence - ;; Lists - (list (loop :repeat (1+ (- (length sequence) n)) - :for seq :on sequence - :collect (take n seq))) - - ;; General sequences - (sequence (loop :for i :to (- (length sequence) n) - :collect (subseq sequence i (+ i n)))))) - - (defun %reevaluate-constant (name value test) (if (not (boundp name)) value @@ -246,33 +135,6 @@ ,@(when documentation `(,documentation)))) - (defun riffle (list obj) - "Insert the item `obj` in between each element of `list`." - (loop :for (x . xs) :on list - :collect x - :when xs - :collect obj)) - - - (defun tree-collect (predicate tree) - "Returns a list of every node in the `tree` that satisfies the `predicate`. If there are any improper lists in the tree, the `predicate` is also applied to their dotted elements." - (let ((sentinel (gensym))) - (flet ((my-cdr (obj) - (cond ((consp obj) - (let ((result (cdr obj))) - (if (listp result) - result - (list result sentinel)))) - (t - (list sentinel))))) - (loop :for (item . rest) :on tree :by #'my-cdr - :until (eq item sentinel) - :if (funcall predicate item) collect item - :else - :if (listp item) - :append (tree-collect predicate item))))) - - (defmacro ensure-gethash (key hash-table &optional default) "Like `gethash`, but if `key` is not found in the `hash-table` saves the `default` under key before returning it. Secondary return value is true if key was @@ -283,11 +145,130 @@ (values (setf (gethash ,key ,hash-table) ,default) nil)))) - (defun required-argument (&optional name) - "Signals an error for a missing argument of `name`. Intended for -use as an initialization form for structure and class-slots, and -a default value for required keyword arguments." - (error "Required argument ~@[~S ~]missing." name)) + (defun hash-table-alist (table) + "Returns an association list containing the keys and values of hash table +`table`." + (let ((alist nil)) + (maphash (lambda (k v) + (push (cons k v) alist)) + table) + alist)) + + + (defun hash-table-plist (table) + "Returns a property list containing the keys and values of hash table +`table`." + (let ((plist nil)) + (maphash (lambda (k v) + (setf plist (list* k v plist))) + table) + plist)) + + + (declaim (inline maphash-keys)) + (defun maphash-keys (function table) + "Like `maphash`, but calls `function` with each key in the hash table `table`." + (maphash (lambda (k v) + (declare (ignore v)) + (funcall function k)) + table)) + + + (defun hash-table-keys (table) + "Returns a list containing the keys of hash table `table`." + (let ((keys nil)) + (maphash-keys (lambda (k) + (push k keys)) + table) + keys)) + + + (declaim (inline maphash-values)) + (defun maphash-values (function table) + "Like `maphash`, but calls `function` with each value in the hash table `table`." + (maphash (lambda (k v) + (declare (ignore k)) + (funcall function v)) + table)) + + + (defun hash-table-values (table) + "Returns a list containing the values of hash table `table`." + (let ((values nil)) + (maphash-values (lambda (v) + (push v values)) + table) + values)) + + + (defun take (n sequence) + "Take the first `n` elements from `sequence`." + (subseq sequence 0 n)) + + + (defun n-grams (n sequence) + "Find all `n`-grams of the sequence `sequence`." + (assert (and (plusp n) + (<= n (length sequence)))) + + (etypecase sequence + ;; Lists + (list (loop :repeat (1+ (- (length sequence) n)) + :for seq :on sequence + :collect (take n seq))) + + ;; General sequences + (sequence (loop :for i :to (- (length sequence) n) + :collect (subseq sequence i (+ i n)))))) + + + (defmacro once-only (specs &body forms) + "Evaluates `forms` with symbols specified in `specs` rebound to temporary +variables, ensuring that each initform is evaluated only once. + +Each of `specs` must either be a symbol naming the variable to be rebound, or of +the form: + + (symbol initform) + +Bare symbols in `specs` are equivalent to + + (symbol symbol) + +Example: + + (defmacro cons1 (x) (once-only (x) `(cons ,x ,x))) + (let ((y 0)) (cons1 (incf y))) => (1 . 1)" + (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) + (names-and-forms (mapcar (lambda (spec) + (etypecase spec + (list + (destructuring-bind (name form) spec + (cons name form))) + (symbol + (cons spec spec)))) + specs))) + ;; bind in user-macro + `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) + gensyms names-and-forms) + ;; bind in final expansion + `(let (,,@(mapcar (lambda (g n) + ``(,,g ,,(cdr n))) + gensyms names-and-forms)) + ;; bind in user-macro + ,(let ,(mapcar (lambda (n g) (list (car n) g)) + names-and-forms gensyms) + ,@forms))))) + + + (defun rcurry (function &rest arguments) + "Returns a function that applies the arguments it is called +with and `arguments` to `function`." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (multiple-value-call fn (values-list more) (values-list arguments))))) (defmacro with-open-file* ((stream filespec &key direction element-type @@ -342,29 +323,87 @@ :while (= bytes-read buffer-size))))))) - (defun hash-table-alist (table) - "Returns an association list containing the keys and values of hash table -`table`." - (let ((alist nil)) - (maphash (lambda (k v) - (push (cons k v) alist)) - table) - alist)) + (defun required-argument (&optional name) + "Signals an error for a missing argument of `name`. Intended for +use as an initialization form for structure and class-slots, and +a default value for required keyword arguments." + (error "Required argument ~@[~S ~]missing." name)) + + + (defun riffle (list obj) + "Insert the item `obj` in between each element of `list`." + (loop :for (x . xs) :on list + :collect x + :when xs + :collect obj)) + + + (defun tree-collect (predicate tree) + "Returns a list of every node in the `tree` that satisfies the `predicate`. If there are any improper lists in the tree, the `predicate` is also applied to their dotted elements." + (let ((sentinel (gensym))) + (flet ((my-cdr (obj) + (cond ((consp obj) + (let ((result (cdr obj))) + (if (listp result) + result + (list result sentinel)))) + (t + (list sentinel))))) + (loop :for (item . rest) :on tree :by #'my-cdr + :until (eq item sentinel) + :if (funcall predicate item) collect item + :else + :if (listp item) + :append (tree-collect predicate item))))) + + + (deftype string-designator () + "A string designator type. A string designator is either a string, a symbol, +or a character." + `(or symbol string character)) - (defun hash-table-plist (table) - "Returns a property list containing the keys and values of hash table -`table`." - (let ((plist nil)) - (maphash (lambda (k v) - (setf plist (list* k v plist))) - table) - plist)) + (defmacro with-gensyms (names &body forms) + "Binds each variable named by a symbol in `names` to a unique symbol around +`forms`. Each of `names` must either be either a symbol, or of the form: + + (symbol string-designator) + +Bare symbols appearing in `names` are equivalent to: + + (symbol symbol) + +The string-designator is used as the argument to `gensym` when constructing the +unique symbol the named variable will be bound to." + `(let ,(mapcar (lambda (name) + (multiple-value-bind (symbol string) + (etypecase name + (symbol + (values name (symbol-name name))) + ((cons symbol (cons string-designator null)) + (values (first name) (string (second name))))) + `(,symbol (gensym ,string)))) + names) + ,@forms)) + + (defmacro with-unique-names (names &body forms) + "Binds each variable named by a symbol in `names` to a unique symbol around +`forms`. Each of `names` must either be either a symbol, or of the form: + + (symbol string-designator) + +Bare symbols appearing in `names` are equivalent to: + + (symbol symbol) + +The string-designator is used as the argument to `gensym` when constructing the +unique symbol the named variable will be bound to." + `(with-gensyms ,names ,@forms)) (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(with-gensyms with-unique-names once-only compose curry rcurry - n-grams define-constant riffle tree-collect ensure-gethash - required-argument read-file-into-string hash-table-alist - hash-table-plist))) + (export '(compose curry define-constant ensure-gethash hash-table-alist + hash-table-plist hash-table-keys hash-table-values n-grams + once-only rcurry read-file-into-string required-argument riffle + tree-collect with-gensyms with-unique-names))) ;;;; END OF quickutils.lisp ;;;;