# HG changeset patch # User Steve Losh # Date 1677804775 18000 # Node ID 43050007ebb5181d7f48f9beff5c1d3a0c8932f1 # Parent e1295ede4c11dce6b69b73e46ce66f40e008b640 Update to latest utils, fix errors diff -r e1295ede4c11 -r 43050007ebb5 Makefile --- a/Makefile Mon Dec 23 17:01:59 2019 -0500 +++ b/Makefile Thu Mar 02 19:52:55 2023 -0500 @@ -1,22 +1,11 @@ -.PHONY: deploy update-deps - -lisps := $(shell ffind '\.(asd|lisp|ros)$$') +.PHONY: all clean -quickutils.lisp: make-quickutils.lisp - sbcl --noinform --load make-quickutils.lisp --eval '(quit)' +lisps := $(shell ffind '\.(asd|lisp)$$') -build/silt: $(lisps) - sbcl --disable-debugger --noinform --load 'build/build.lisp' --quit - mv silt build/silt +all: silt -update-deps: - hg -R /home/sjl/cl-losh pull -u - hg -R /home/sjl/beast pull -u +silt: $(lisps) + sbcl --noinform --disable-debugger --load 'build.lisp' --quit -/opt/silt/silt: update-deps build/silt - rm /opt/silt/silt - cp build/silt /opt/silt/silt - -deploy: build/silt - rsync --exclude=build/silt --exclude=.hg --exclude=silt.prof -avz . silt:/home/sjl/silt2 - ssh silt make -C /home/sjl/silt2 /opt/silt/silt +clean: + rm silt diff -r e1295ede4c11 -r 43050007ebb5 build.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/build.lisp Thu Mar 02 19:52:55 2023 -0500 @@ -0,0 +1,17 @@ +(unless (find-package :silt) + (ql:quickload '(:silt) :silent t)) + +(declaim (optimize (debug 1) (safety 1) (speed 3))) + +(let ((*standard-output* (make-broadcast-stream)) ; shut + (*error-output* (make-broadcast-stream))) ; up + (asdf:load-system 'silt :force t)) + +(defun main (&rest argv) + (declare (ignore argv)) + (silt::main)) + +(sb-ext:save-lisp-and-die "silt" + :toplevel 'silt::run + :save-runtime-options t + :executable t) diff -r e1295ede4c11 -r 43050007ebb5 build/build.lisp --- a/build/build.lisp Mon Dec 23 17:01:59 2019 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -(unless (find-package :silt) - (ql:quickload '(:silt) :silent t)) - -(declaim (optimize (debug 1) (safety 1) (speed 3))) - -(let ((*standard-output* (make-broadcast-stream)) ; shut - (*error-output* (make-broadcast-stream))) ; up - (asdf:load-system 'silt :force t)) - -(defun main (&rest argv) - (declare (ignore argv)) - (silt::main)) - -(sb-ext:save-lisp-and-die "silt" - :toplevel 'silt::run - :save-runtime-options t - :executable t) diff -r e1295ede4c11 -r 43050007ebb5 make-quickutils.lisp --- a/make-quickutils.lisp Mon Dec 23 17:01:59 2019 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,24 +0,0 @@ -(ql:quickload 'quickutil) - -(qtlc:save-utils-as - "quickutils.lisp" - :utilities '( - :with-gensyms - :once-only - :compose - :curry - :rcurry - :parse-body - ; :n-grams - :define-constant - :hash-table-key-exists-p - :hash-table-keys - :hash-table-values - :map-product - ; :switch - ; :while - ; :ensure-boolean - ; :iota - ; :zip - ) - :package "SILT.QUICKUTILS") diff -r e1295ede4c11 -r 43050007ebb5 package.lisp --- a/package.lisp Mon Dec 23 17:01:59 2019 -0500 +++ b/package.lisp Thu Mar 02 19:52:55 2023 -0500 @@ -1,9 +1,3 @@ -(defpackage #:silt - (:use - #:cl - #:iterate - #:losh - #:beast - #:silt.quickutils) - (:export - #:main)) +(defpackage :silt + (:use :cl :iterate :losh :beast) + (:export :main)) diff -r e1295ede4c11 -r 43050007ebb5 quickutils.lisp --- a/quickutils.lisp Mon Dec 23 17:01:59 2019 -0500 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,322 +0,0 @@ -;;;; This file was automatically generated by Quickutil. -;;;; See http://quickutil.org for details. - -;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :PARSE-BODY :DEFINE-CONSTANT :HASH-TABLE-KEY-EXISTS-P :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT) :ensure-package T :package "SILT.QUICKUTILS") - -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package "SILT.QUICKUTILS") - (defpackage "SILT.QUICKUTILS" - (:documentation "Package that contains Quickutil utility functions.") - (:use #:cl)))) - -(in-package "SILT.QUICKUTILS") - -(when (boundp '*utilities*) - (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS - :MAKE-GENSYM-LIST :ONCE-ONLY - :ENSURE-FUNCTION :COMPOSE :CURRY - :RCURRY :PARSE-BODY :DEFINE-CONSTANT - :HASH-TABLE-KEY-EXISTS-P :MAPHASH-KEYS - :HASH-TABLE-KEYS :MAPHASH-VALUES - :HASH-TABLE-VALUES :MAPPEND - :MAP-PRODUCT)))) - - (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)) - -(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`, -using the second (optional, defaulting to `\"G\"`) argument." - (let ((g (if (typep x '(integer 0)) x (string x)))) - (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. - (declaim (inline ensure-function)) - - (declaim (ftype (function (t) (values function &optional)) - ensure-function)) - (defun ensure-function (function-designator) - "Returns the function designated by `function-designator`: -if `function-designator` is a function, it is returned, otherwise -it must be a function name and its `fdefinition` is returned." - (if (functionp function-designator) - function-designator - (fdefinition function-designator))) - ) ; eval-when - - (defun compose (function &rest more-functions) - "Returns a function composed of `function` and `more-functions` that applies its ; -arguments to to each in turn, starting from the rightmost of `more-functions`, -and then calling the next one with the primary value of the last." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (reduce (lambda (f g) - (let ((f (ensure-function f)) - (g (ensure-function g))) - (lambda (&rest arguments) - (declare (dynamic-extent arguments)) - (funcall f (apply g arguments))))) - more-functions - :initial-value function)) - - (define-compiler-macro compose (function &rest more-functions) - (labels ((compose-1 (funs) - (if (cdr funs) - `(funcall ,(car funs) ,(compose-1 (cdr funs))) - `(apply ,(car funs) arguments)))) - (let* ((args (cons function more-functions)) - (funs (make-gensym-list (length args) "COMPOSE"))) - `(let ,(loop for f in funs for arg in args - collect `(,f (ensure-function ,arg))) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (lambda (&rest arguments) - (declare (dynamic-extent arguments)) - ,(compose-1 funs)))))) - - - (defun curry (function &rest arguments) - "Returns a function that applies `arguments` and the arguments -it is called with to `function`." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (let ((fn (ensure-function function))) - (lambda (&rest more) - (declare (dynamic-extent more)) - ;; Using M-V-C we don't need to append the arguments. - (multiple-value-call fn (values-list arguments) (values-list more))))) - - (define-compiler-macro curry (function &rest arguments) - (let ((curries (make-gensym-list (length arguments) "CURRY")) - (fun (gensym "FUN"))) - `(let ((,fun (ensure-function ,function)) - ,@(mapcar #'list curries arguments)) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (lambda (&rest more) - (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 parse-body (body &key documentation whole) - "Parses `body` into `(values remaining-forms declarations doc-string)`. -Documentation strings are recognized only if `documentation` is true. -Syntax errors in body are signalled and `whole` is used in the signal -arguments when given." - (let ((doc nil) - (decls nil) - (current nil)) - (tagbody - :declarations - (setf current (car body)) - (when (and documentation (stringp current) (cdr body)) - (if doc - (error "Too many documentation strings in ~S." (or whole body)) - (setf doc (pop body))) - (go :declarations)) - (when (and (listp current) (eql (first current) 'declare)) - (push (pop body) decls) - (go :declarations))) - (values body (nreverse decls) doc))) - - - (defun %reevaluate-constant (name value test) - (if (not (boundp name)) - value - (let ((old (symbol-value name)) - (new value)) - (if (not (constantp name)) - (prog1 new - (cerror "Try to redefine the variable as a constant." - "~@<~S is an already bound non-constant variable ~ - whose value is ~S.~:@>" name old)) - (if (funcall test old new) - old - (restart-case - (error "~@<~S is an already defined constant whose value ~ - ~S is not equal to the provided initial value ~S ~ - under ~S.~:@>" name old new test) - (ignore () - :report "Retain the current value." - old) - (continue () - :report "Try to redefine the constant." - new))))))) - - (defmacro define-constant (name initial-value &key (test ''eql) documentation) - "Ensures that the global variable named by `name` is a constant with a value -that is equal under `test` to the result of evaluating `initial-value`. `test` is a -function designator that defaults to `eql`. If `documentation` is given, it -becomes the documentation string of the constant. - -Signals an error if `name` is already a bound non-constant variable. - -Signals an error if `name` is already a constant variable whose value is not -equal under `test` to result of evaluating `initial-value`." - `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test) - ,@(when documentation `(,documentation)))) - - - (defun hash-table-key-exists-p (hash-table key) - "Does `key` exist in `hash-table`?" - (nth-value 1 (gethash key hash-table))) - - - (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 mappend (function &rest lists) - "Applies `function` to respective element(s) of each `list`, appending all the -all the result list to a single list. `function` must return a list." - (loop for results in (apply #'mapcar function lists) - append results)) - - - (defun map-product (function list &rest more-lists) - "Returns a list containing the results of calling `function` with one argument -from `list`, and one from each of `more-lists` for each combination of arguments. -In other words, returns the product of `list` and `more-lists` using `function`. - -Example: - - (map-product 'list '(1 2) '(3 4) '(5 6)) - => ((1 3 5) (1 3 6) (1 4 5) (1 4 6) - (2 3 5) (2 3 6) (2 4 5) (2 4 6))" - (labels ((%map-product (f lists) - (let ((more (cdr lists)) - (one (car lists))) - (if (not more) - (mapcar f one) - (mappend (lambda (x) - (%map-product (curry f x) more)) - one))))) - (%map-product (ensure-function function) (cons list more-lists)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(with-gensyms with-unique-names once-only compose curry rcurry - parse-body define-constant hash-table-key-exists-p hash-table-keys - hash-table-values map-product))) - -;;;; END OF quickutils.lisp ;;;; diff -r e1295ede4c11 -r 43050007ebb5 silt.asd --- a/silt.asd Mon Dec 23 17:01:59 2019 -0500 +++ b/silt.asd Thu Mar 02 19:52:55 2023 -0500 @@ -7,14 +7,13 @@ :license "MIT/X11" :version "0.0.1" - :depends-on (#:iterate - #:cl-charms - #+sbcl #:sb-sprof - #:alexandria - #:losh - #:beast) + :depends-on (:iterate + :cl-charms + #+sbcl :sb-sprof + :alexandria + :losh + :beast) :serial t - :components ((:file "quickutils") - (:file "package") + :components ((:file "package") (:file "silt"))) diff -r e1295ede4c11 -r 43050007ebb5 silt.lisp --- a/silt.lisp Mon Dec 23 17:01:59 2019 -0500 +++ b/silt.lisp Thu Mar 02 19:52:55 2023 -0500 @@ -1,4 +1,4 @@ -(in-package #:silt) +(in-package :silt) #+sbcl (require :sb-sprof) ; (declaim (optimize (speed 3) (debug 0) (safety 0))) @@ -7,8 +7,8 @@ ;;;; Data ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-constant +world-exponent+ 10) -(define-constant +world-size+ (expt 2 +world-exponent+)) +(alexandria:define-constant +world-exponent+ 10) +(alexandria:define-constant +world-size+ (expt 2 +world-exponent+)) (defparameter *screen-width* 1) (defparameter *screen-height* 1) (defparameter *screen-center-x* 1) @@ -50,7 +50,7 @@ `(progn ,@(iterate (for n :from 0) (for (constant nil nil) :in colors) - (collect `(define-constant ,constant ,n))) + (collect `(alexandria:define-constant ,constant ,n))) (defun init-colors () ,@(iterate (for (constant fg bg) :in colors) @@ -94,9 +94,9 @@ (decf (car entry))) (dead (entry) (minusp (car entry)))) - (-<> ticklist - (mapc #'decrement <>) - (remove-if #'dead <>)))) + (_ ticklist + (mapc #'decrement _) + (remove-if #'dead _)))) (defun ticklist-contents (ticklist) (mapcar #'cdr ticklist)) @@ -386,10 +386,10 @@ ;;;; Name Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *name-syllables* - (-<> "syllables.txt" + (_ "syllables.txt" alexandria:read-file-into-string read-from-string - (coerce <> 'vector))) + (coerce _ 'vector))) (defun random-name () (format nil "~:(~{~A~}~)" @@ -842,11 +842,11 @@ (40 (log-message "The monolith begins to glow.")) (0 (progn (setf countdown 100) - (-<> (make-creature (coords/x m) (1+ (coords/y m))) + (_ (make-creature (coords/x m) (1+ (coords/y m))) creature-name (log-message "The monolith flashes brightly and ~A appears in front of it!" - <>)))))))) + _)))))))) (defun fountain-act (f) (with-slots (recent) f