# HG changeset patch # User Steve Losh # Date 1638466537 18000 # Node ID 5341efcdeefe6739ca6cfeaf9dda40db77fdcf68 # Parent f51cda0a23b2b628a1c291d339280332e9914158 Update to latest cl-losh diff -r f51cda0a23b2 -r 5341efcdeefe Makefile --- a/Makefile Sun Jun 09 18:54:56 2019 -0400 +++ b/Makefile Thu Dec 02 12:35:37 2021 -0500 @@ -1,10 +1,4 @@ -.PHONY: vendor test - -# Vendor ---------------------------------------------------------------------- -vendor/quickutils.lisp: vendor/make-quickutils.lisp - cd vendor && sbcl --noinform --load make-quickutils.lisp --eval '(quit)' - -vendor: vendor/quickutils.lisp +.PHONY: test # Test ------------------------------------------------------------------------ test: diff -r f51cda0a23b2 -r 5341efcdeefe flax.asd --- a/flax.asd Sun Jun 09 18:54:56 2019 -0400 +++ b/flax.asd Thu Dec 02 12:35:37 2021 -0500 @@ -22,9 +22,7 @@ :serial t :components ((:module "vendor" :serial t - :components ((:file "quickutils-package") - (:file "quickutils") - (:module "lofi-tri" + :components ((:module "lofi-tri" :components ((:file "lofi.tri"))))) (:module "src" :serial t :components diff -r f51cda0a23b2 -r 5341efcdeefe src/drawing/png.lisp --- a/src/drawing/png.lisp Sun Jun 09 18:54:56 2019 -0400 +++ b/src/drawing/png.lisp Thu Dec 02 12:35:37 2021 -0500 @@ -60,8 +60,8 @@ ((ax ay (a rect)) (bx by (b rect)) (r (round-corners rect))) - (-<> (paths:make-rectangle-path ax ay bx by :round r) - (vectors:update-state (state canvas) <>)))) + (_ (paths:make-rectangle-path ax ay bx by :round r) + (vectors:update-state (state canvas) _)))) ;;;; Circles ------------------------------------------------------------------ @@ -69,16 +69,16 @@ (with-coordinates canvas ((x y (center circ)) (r (radius circ))) - (-<> (paths:make-circle-path x y r) - (vectors:update-state (state canvas) <>)))) + (_ (paths:make-circle-path x y r) + (vectors:update-state (state canvas) _)))) ;;;; Points ------------------------------------------------------------------- (defmethod draw ((canvas png-canvas) (p point)) (with-coordinates canvas ((x y (location p))) - (-<> (paths:make-circle-path x y 2) - (vectors:update-state (state canvas) <>)))) + (_ (paths:make-circle-path x y 2) + (vectors:update-state (state canvas) _)))) ;;;; Paths -------------------------------------------------------------------- @@ -128,12 +128,12 @@ p))) (defmethod draw ((canvas png-canvas) (p path)) - (-<> (points p) - (mapcar-curried #'convert-points canvas <>) + (_ (points p) + (mapcar-curried #'convert-points canvas _) fill-missing-control-points make-vector-path - (paths:stroke-path <> 1) - (vectors:update-state (state canvas) <>))) + (paths:stroke-path _ 1) + (vectors:update-state (state canvas) _))) ;;;; Triangles ---------------------------------------------------------------- @@ -142,13 +142,13 @@ ((ax ay (a tri)) (bx by (b tri)) (cx cy (c tri))) - (-<> (list (cons ax ay) + (_ (list (cons ax ay) (cons bx by) (cons cx cy) (cons ax ay)) paths:make-simple-path - (paths:stroke-path <> 1) - (vectors:update-state (state canvas) <>)))) + (paths:stroke-path _ 1) + (vectors:update-state (state canvas) _)))) ;;;; Rendering ---------------------------------------------------------------- diff -r f51cda0a23b2 -r 5341efcdeefe src/looms/001-triangles.lisp --- a/src/looms/001-triangles.lisp Sun Jun 09 18:54:56 2019 -0400 +++ b/src/looms/001-triangles.lisp Thu Dec 02 12:35:37 2021 -0500 @@ -51,7 +51,7 @@ (defun generate-universe-even (depth &aux (triangles (initial-triangles))) (do-repeat depth - (zapf triangles (mappend #'split-triangle-evenly %))) + (zapf triangles (alexandria:mappend #'split-triangle-evenly %))) triangles) @@ -69,10 +69,10 @@ (defun split-triangle-self-balancing (triangle) (destructuring-bind (a b c) (find-longest-side triangle) - (let ((p (-<> (random-gaussian 0.5 0.1 #'rand) - (clamp 0.3 0.7 <>) - (round-to <> 1/100) - (vlerp b c <>)))) + (let ((p (_ (random-gaussian 0.5 0.1 #'rand) + (clamp 0.3 0.7 _) + (round-to _ 1/100) + (vlerp b c _)))) (list (triangle p b a) (triangle p a c))))) @@ -100,11 +100,12 @@ (randomly-initialize ((depth (random-range-inclusive 14 19 #'rand)))) (flax.drawing:with-rendering (canvas filetype filename width height)) (progn - (-<> (generate-universe-balancing depth) + (_ (generate-universe-balancing depth) convert - (flax.drawing:render canvas <>)) + (flax.drawing:render canvas _)) (values depth)))) ;; (declaim (optimize (speed 1))) -;; (time (loom nil "out" :svg 800 800 :depth 16)) + +;; (time (loom nil "out" :png 800 800 :depth 16)) diff -r f51cda0a23b2 -r 5341efcdeefe src/looms/003-basic-l-systems.lisp --- a/src/looms/003-basic-l-systems.lisp Sun Jun 09 18:54:56 2019 -0400 +++ b/src/looms/003-basic-l-systems.lisp Thu Dec 02 12:35:37 2021 -0500 @@ -21,7 +21,8 @@ (funcall callback iteration word)) (if (= iterations iteration) word - (recur (funcall mutate (mappend (rcurry #'gethash (productions lsystem)) word)) + (recur (funcall mutate (alexandria:mappend + (rcurry #'gethash (productions lsystem)) word)) (1+ iteration))))) (defmacro define-lsystem (name axiom &rest productions) diff -r f51cda0a23b2 -r 5341efcdeefe src/looms/004-turtle-curves.lisp --- a/src/looms/004-turtle-curves.lisp Sun Jun 09 18:54:56 2019 -0400 +++ b/src/looms/004-turtle-curves.lisp Thu Dec 02 12:35:37 2021 -0500 @@ -121,9 +121,9 @@ ;;;; L-Systems ---------------------------------------------------------------- (defun expand (word productions) - (mappend (lambda (letter) - (ensure-list (or (getf productions letter) letter))) - word)) + (alexandria:mappend (lambda (letter) + (ensure-list (or (getf productions letter) letter))) + word)) (defun run-l-system (axiom productions iterations) (iterate @@ -398,11 +398,12 @@ (flax.drawing:with-rendering (canvas filetype filename width height :background bg :padding 0.05)) (progn - (-<> (run-l-system axiom productions iterations) + (_ (run-l-system axiom productions iterations) turtle-draw transform-to-fit - (flax.drawing:render canvas <>)) + (flax.drawing:render canvas _)) (values (name l-system) iterations mutagen)))) +;; (time (loom 1 "out" :svg 500 500)) diff -r f51cda0a23b2 -r 5341efcdeefe src/looms/005-simple-triangulations.lisp --- a/src/looms/005-simple-triangulations.lisp Sun Jun 09 18:54:56 2019 -0400 +++ b/src/looms/005-simple-triangulations.lisp Thu Dec 02 12:35:37 2021 -0500 @@ -64,9 +64,9 @@ (random-range 0.05 0.2 #'rand))) (points (round-to (random-range-inclusive 100 1000 #'rand) 10)))) (progn - (-<> (generate generator points) - (convert <> ratio) - (flax.drawing:render canvas <>)) + (_ (generate generator points) + (convert _ ratio) + (flax.drawing:render canvas _)) (values generator-name points ratio)))) diff -r f51cda0a23b2 -r 5341efcdeefe src/looms/006-tracing-lines.lisp --- a/src/looms/006-tracing-lines.lisp Sun Jun 09 18:54:56 2019 -0400 +++ b/src/looms/006-tracing-lines.lisp Thu Dec 02 12:35:37 2021 -0500 @@ -62,9 +62,9 @@ (lines (round-to (random-range 80 140 #'rand) 10)))) (let ((*spread-y* (/ 0.15 lines)))) (progn - (-<> (generate-lines points lines) + (_ (generate-lines points lines) convert-lines - (flax.drawing:render canvas <>)) + (flax.drawing:render canvas _)) (values lines points)))) ;; (time (loom 4 "out" :svg 800 800)) diff -r f51cda0a23b2 -r 5341efcdeefe src/looms/007-stippling.lisp --- a/src/looms/007-stippling.lisp Sun Jun 09 18:54:56 2019 -0400 +++ b/src/looms/007-stippling.lisp Thu Dec 02 12:35:37 2021 -0500 @@ -119,11 +119,11 @@ (randomly-initialize ((shapes (clamp 1 100 (random-gaussian-integer 6 2 #'rand))))) (progn - (-<> (gen shapes) - (stipple <> (/ (or ratio 100000) shapes)) + (_ (gen shapes) + (stipple _ (/ (or ratio 100000) shapes)) convert - (flax.drawing:render canvas <>)) + (flax.drawing:render canvas _)) (values shapes)))) -;; (time (loom 11 "out" :svg 800 800)) -;; (time (loom 112 "out" :png 800 800 :ratio 4000000)) +(time (loom 11 "out" :svg 800 800)) +(time (loom 112 "out" :png 800 800 :ratio 4000000)) diff -r f51cda0a23b2 -r 5341efcdeefe src/package.lisp --- a/src/package.lisp Sun Jun 09 18:54:56 2019 -0400 +++ b/src/package.lisp Thu Dec 02 12:35:37 2021 -0500 @@ -1,5 +1,5 @@ (defpackage :flax.base - (:use :cl :iterate :losh :flax.quickutils + (:use :cl :iterate :losh :3d-vectors :3d-matrices) (:export @@ -12,7 +12,7 @@ :mapcar-curried)) (defpackage :flax.colors - (:use :cl :iterate :losh :flax.base :flax.quickutils) + (:use :cl :iterate :losh :flax.base) (:export :color :with-color @@ -20,7 +20,7 @@ :rgb)) (defpackage :flax.transform - (:use :cl :iterate :losh :flax.base :flax.quickutils + (:use :cl :iterate :losh :flax.base :3d-vectors :3d-matrices) (:export @@ -33,7 +33,7 @@ :ntransformf)) (defpackage :flax.drawing - (:use :cl :iterate :losh :flax.base :flax.quickutils + (:use :cl :iterate :losh :flax.base :flax.colors :flax.transform :3d-vectors @@ -53,50 +53,50 @@ (defpackage :flax.looms.001-triangles - (:use :cl :iterate :losh :flax.base :flax.quickutils + (:use :cl :iterate :losh :flax.base :3d-vectors) (:export :loom)) (defpackage :flax.looms.002-wobbly-lines - (:use :cl :iterate :losh :flax.base :flax.quickutils + (:use :cl :iterate :losh :flax.base :flax.colors :3d-vectors) (:export :loom)) (defpackage :flax.looms.003-basic-l-systems - (:use :cl :iterate :losh :flax.base :flax.quickutils + (:use :cl :iterate :losh :flax.base :flax.colors :3d-vectors) (:export :loom)) (defpackage :flax.looms.004-turtle-curves - (:use :cl :iterate :losh :flax.base :flax.quickutils + (:use :cl :iterate :losh :flax.base :flax.colors :flax.transform :3d-vectors) (:export :loom)) (defpackage :flax.looms.005-simple-triangulations - (:use :cl :iterate :losh :flax.base :flax.quickutils + (:use :cl :iterate :losh :flax.base :flax.colors :3d-vectors) (:export :loom)) (defpackage :flax.looms.006-tracing-lines - (:use :cl :iterate :losh :flax.base :flax.quickutils + (:use :cl :iterate :losh :flax.base :flax.colors :3d-vectors) (:export :loom)) (defpackage :flax.looms.007-stipple - (:use :cl :iterate :losh :flax.base :flax.quickutils + (:use :cl :iterate :losh :flax.base :flax.colors :3d-vectors) (:export :loom)) (defpackage :flax.scratch - (:use :cl :iterate :losh :flax.base :flax.quickutils + (:use :cl :iterate :losh :flax.base :flax.colors :flax.transform :3d-vectors) diff -r f51cda0a23b2 -r 5341efcdeefe src/transform.lisp --- a/src/transform.lisp Sun Jun 09 18:54:56 2019 -0400 +++ b/src/transform.lisp Thu Dec 02 12:35:37 2021 -0500 @@ -34,9 +34,9 @@ (defmacro transformation (&rest transforms) - `(-<> (id) + `(_ (id) ,@(iterate (for (name . body) :in transforms) - (collect `(,name <> ,@body))))) + (collect `(,name _ ,@body))))) (defgeneric ntransform (object transformation)) diff -r f51cda0a23b2 -r 5341efcdeefe vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Sun Jun 09 18:54:56 2019 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -(ql:quickload 'quickutil) - -(qtlc:save-utils-as - "quickutils.lisp" - :utilities '( - - :alist-hash-table - :compose - :curry - :ensure-list - :mappend - :once-only - :rcurry - :symb - :with-gensyms - - ) - :package "FLAX.QUICKUTILS") diff -r f51cda0a23b2 -r 5341efcdeefe vendor/quickutils-package.lisp --- a/vendor/quickutils-package.lisp Sun Jun 09 18:54:56 2019 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,12 +0,0 @@ -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package "FLAX.QUICKUTILS") - (defpackage "FLAX.QUICKUTILS" - (:documentation "Package that contains Quickutil utility functions.") - (:use :cl)))) - -(in-package "FLAX.QUICKUTILS") - -;; need to define this here so sbcl will shut the hell up about it being -;; undefined when compiling quickutils.lisp. computers are trash. -(defparameter *utilities* nil) - diff -r f51cda0a23b2 -r 5341efcdeefe vendor/quickutils.lisp --- a/vendor/quickutils.lisp Sun Jun 09 18:54:56 2019 -0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,230 +0,0 @@ -;;;; This file was automatically generated by Quickutil. -;;;; See http://quickutil.org for details. - -;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:ALIST-HASH-TABLE :COMPOSE :CURRY :ENSURE-LIST :MAPPEND :ONCE-ONLY :RCURRY :SYMB :WITH-GENSYMS) :ensure-package T :package "FLAX.QUICKUTILS") - -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package "FLAX.QUICKUTILS") - (defpackage "FLAX.QUICKUTILS" - (:documentation "Package that contains Quickutil utility functions.") - (:use #:cl)))) - -(in-package "FLAX.QUICKUTILS") - -(when (boundp '*utilities*) - (setf *utilities* (union *utilities* '(:ALIST-HASH-TABLE :MAKE-GENSYM-LIST - :ENSURE-FUNCTION :COMPOSE :CURRY - :ENSURE-LIST :MAPPEND :ONCE-ONLY - :RCURRY :MKSTR :SYMB - :STRING-DESIGNATOR :WITH-GENSYMS)))) - - (defun alist-hash-table (alist &rest hash-table-initargs) - "Returns a hash table containing the keys and values of the association list -`alist`. Hash table is initialized using the `hash-table-initargs`." - (let ((table (apply #'make-hash-table hash-table-initargs))) - (dolist (cons alist) - (setf (gethash (car cons) table) (cdr cons))) - table)) - -(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 -(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 ensure-list (list) - "If `list` is a list, it is returned. Otherwise returns the list designated by `list`." - (if (listp list) - list - (list list))) - - - (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)) - - - (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))))) - - - (defun mkstr (&rest args) - "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string. - -Extracted from _On Lisp_, chapter 4." - (with-output-to-string (s) - (dolist (a args) (princ a s)))) - - - (defun symb (&rest args) - "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol. - -Extracted from _On Lisp_, chapter 4. - -See also: `symbolicate`" - (values (intern (apply #'mkstr args)))) - - - (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) - (export '(alist-hash-table compose curry ensure-list mappend once-only rcurry - symb with-gensyms with-unique-names))) - -;;;; END OF quickutils.lisp ;;;;