5341efcdeefe

Update to latest cl-losh
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Thu, 02 Dec 2021 12:35:37 -0500
parents f51cda0a23b2
children fa5e614ee7f9
branches/tags (none)
files Makefile flax.asd src/drawing/png.lisp src/looms/001-triangles.lisp src/looms/003-basic-l-systems.lisp src/looms/004-turtle-curves.lisp src/looms/005-simple-triangulations.lisp src/looms/006-tracing-lines.lisp src/looms/007-stippling.lisp src/package.lisp src/transform.lisp vendor/make-quickutils.lisp vendor/quickutils-package.lisp vendor/quickutils.lisp

Changes

--- 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:
--- 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
--- 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 ----------------------------------------------------------------
--- 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))
--- 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)
--- 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))
--- 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))))
 
 
--- 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))
--- 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))
--- 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)
--- 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))
--- 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")
--- 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)
-
--- 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 ;;;;