1.1--- a/.hgignore Sun Mar 17 22:21:29 2024 -0400
1.2+++ b/.hgignore Mon Mar 18 21:47:33 2024 -0400
1.3@@ -7,4 +7,5 @@
1.4 .*[.]dylib$
1.5 .*[.]dll$
1.6 .*[.]a$
1.7+.*[.]core$
1.8 [.]stash/.*
1.9\ No newline at end of file
2.1--- a/emacs/default.el Sun Mar 17 22:21:29 2024 -0400
2.2+++ b/emacs/default.el Mon Mar 18 21:47:33 2024 -0400
2.3@@ -87,7 +87,7 @@
2.4 corfu orderless cape ;; completion
2.5 slime ;; common lisp server
2.6 bbdb
2.7- slime-company
2.8+ ;; slime-company
2.9 which-key ;; key helper
2.10 ;; langs
2.11 rust-mode)
3.1--- a/lisp/app/bin/organ.lisp Sun Mar 17 22:21:29 2024 -0400
3.2+++ b/lisp/app/bin/organ.lisp Mon Mar 18 21:47:33 2024 -0400
3.3@@ -9,19 +9,19 @@
3.4
3.5 (defopt organ-help (print-help $cli))
3.6 (defopt organ-version (print-version $cli))
3.7-(defopt organ-log-level (setq *log-level* (if $val :debug nil)))
3.8+(defopt organ-log-level (setq log:*log-level* (if $val :debug nil)))
3.9
3.10-(defcmd organ-inspect (inspect (read-org-file (car $args))))
3.11+(defcmd organ-inspect (inspect (org-parse :document (car $args))))
3.12
3.13 (defcmd organ-show
3.14-(fmt-tree t
3.15- (mapcar (lambda (x) `(,(car x) ,(cddr x)))
3.16- (remove-if-not (lambda (x) (equal (cadr x) (symb 'headline)))
3.17- (org-parse-lines (read-org-file (open (car $args))))))
3.18- :layout :down))
3.19+ (fmt-tree t
3.20+ (mapcar (lambda (x) `(,(car x) ,(cddr x)))
3.21+ (remove-if-not (lambda (x) (equal (cadr x) (symb 'headline)))
3.22+ (org-parse-lines :document (open (car $args)))))
3.23+ :layout :down))
3.24
3.25 (defcmd organ-parse
3.26- (fmt-tree t (remove-if #'null (org-parse-lines (read-org-file (open (car $args))))) :layout :down))
3.27+ (fmt-tree t (remove-if #'null (org-parse-lines :document (open (car $args)))) :layout :down))
3.28
3.29 (define-cli $cli
3.30 :name "organ"
4.1--- a/lisp/app/bin/rdb.lisp Sun Mar 17 22:21:29 2024 -0400
4.2+++ b/lisp/app/bin/rdb.lisp Mon Mar 18 21:47:33 2024 -0400
4.3@@ -2,14 +2,14 @@
4.4
4.5 ;;; Code:
4.6 (uiop:define-package :bin/rdb
4.7- (:use :cl :rdb :std :cli)
4.8+ (:use :cl :rdb :std :cli)
4.9 (:export :main))
4.10
4.11 (in-package :bin/rdb)
4.12
4.13 (defopt rdb-help (print-help $cli))
4.14 (defopt rdb-version (print-version $cli))
4.15-(defopt rdb-log-level (setq *log-level* (if $val :debug nil)))
4.16+(defopt rdb-log-level (setq log:*log-level* (if $val :debug nil)))
4.17 ;; (defopt rdb-config (init-rdb-user-config (parse-file-opt $val)))
4.18 (define-cli $cli
4.19 :name "rdb"
5.1--- a/lisp/app/bin/skel.lisp Sun Mar 17 22:21:29 2024 -0400
5.2+++ b/lisp/app/bin/skel.lisp Mon Mar 18 21:47:33 2024 -0400
5.3@@ -1,6 +1,6 @@
5.4 ;;; Code:
5.5 (uiop:define-package :bin/skel
5.6- (:use :cl :std :cli :skel :log)
5.7+ (:use :cl :std :cli :skel :log :vc)
5.8 (:export :main))
5.9
5.10 (in-package :bin/skel)
5.11@@ -9,7 +9,7 @@
5.12 (defopt skc-version (print-version $cli))
5.13 (defopt skc-log (setq *log-level* (if $val :debug nil)))
5.14 ;; TODO 2023-10-13: almost there
5.15-(defopt skc-config (when $val (init-skel-user-config (parse-file-opt $val))))
5.16+(defopt skc-config (when $val (init-user-skelrc (parse-file-opt $val))))
5.17
5.18 (defcmd skc-init
5.19 (let ((file (when $args (pop $args)))
5.20@@ -113,7 +113,7 @@
5.21 (let ((*log-level* nil))
5.22 (in-readtable :shell)
5.23 (with-cli (opts cmds) $cli
5.24- (init-skel-vars)
5.25+ (load-skelrc)
5.26 ;; TODO 2024-01-01: need to parse out CMD opts from args slot - they still there
5.27 (do-cmd $cli)
5.28 (debug-opts $cli))))
6.1--- a/lisp/ffi/tree-sitter/api.lisp Sun Mar 17 22:21:29 2024 -0400
6.2+++ b/lisp/ffi/tree-sitter/api.lisp Mon Mar 18 21:47:33 2024 -0400
6.3@@ -80,7 +80,7 @@
6.4 (string-to-pass (if (plusp string-start)
6.5 (subseq string string-start string-end)
6.6 string))
6.7- (tree (ts-parser-parse-string parser string-to-pass string-length)))
6.8+ (tree (ts-parser-parse-string parser string string-to-pass string-length)))
6.9 (when (sb-alien:null-alien tree)
6.10 (error 'cant-parse-string
6.11 :string string
7.1--- a/lisp/lib/dat/dat.asd Sun Mar 17 22:21:29 2024 -0400
7.2+++ b/lisp/lib/dat/dat.asd Mon Mar 18 21:47:33 2024 -0400
7.3@@ -1,6 +1,6 @@
7.4 (defsystem :dat
7.5 :description "Data formats"
7.6- :depends-on (:std :obj)
7.7+ :depends-on (:cl-ppcre :std :obj)
7.8 :version "0.1.0"
7.9 :serial t
7.10 :components ((:file "pkg")
7.11@@ -12,6 +12,7 @@
7.12 :components
7.13 ((:file "xml")
7.14 (:file "pkg")
7.15+ (:file "svg")
7.16 (:file "fixml")))
7.17 (:file "toml")
7.18 (:file "arff")
8.1--- a/lisp/lib/dat/xml/pkg.lisp Sun Mar 17 22:21:29 2024 -0400
8.2+++ b/lisp/lib/dat/xml/pkg.lisp Mon Mar 18 21:47:33 2024 -0400
8.3@@ -5,3 +5,7 @@
8.4
8.5 (defpackage :dat/fixml
8.6 (:use :cl :std :dat/xml :dat/proto))
8.7+
8.8+(defpackage :dat/svg
8.9+ (:use :cl :cl-ppcre :std :dat/xml :dat/proto)
8.10+ (:export :parse-svg-file :parse-svg-string))
9.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2+++ b/lisp/lib/dat/xml/svg.lisp Mon Mar 18 21:47:33 2024 -0400
9.3@@ -0,0 +1,635 @@
9.4+;;; dat/xml/svg.lisp --- SVG data encoders
9.5+
9.6+;; based on https://github.com/orthecreedence/cl-svg-polygon
9.7+
9.8+;;; Code:
9.9+(in-package :dat/svg)
9.10+
9.11+;;; MATRIX
9.12+(defun id-matrix (dims)
9.13+ "Return a square identity matrix with the specified "
9.14+ (let ((array (make-array (* dims dims) :initial-element 0.0 :element-type 'single-float)))
9.15+ (dotimes (d dims)
9.16+ (setf (aref array (* d (1+ dims))) 1.0))
9.17+ array))
9.18+
9.19+(defun mat* (m1 m2)
9.20+ "Multiply 3x3 matrices m1 by m2."
9.21+ (let ((new (make-array 9 :initial-element 0.0 :element-type 'single-float)))
9.22+ (dotimes (x 3)
9.23+ (dotimes (y 3)
9.24+ (let ((prod (+ (* (aref m1 (* x 3)) (aref m2 y))
9.25+ (* (aref m1 (+ (* x 3) 1)) (aref m2 (+ y 3)))
9.26+ (* (aref m1 (+ (* x 3) 2)) (aref m2 (+ y 6))))))
9.27+ (setf (aref new (+ y (* x 3))) (coerce prod 'single-float)))))
9.28+ new))
9.29+
9.30+(defun matv* (m v)
9.31+ "Multiple a matrix by a vector, return the resulting vector."
9.32+ (let ((new (make-list 3))
9.33+ (vx (car v))
9.34+ (vy (cadr v))
9.35+ (vz 1))
9.36+ (dotimes (i 3)
9.37+ (setf (nth i new) (+ (* vx (aref m (* i 3)))
9.38+ (* vy (aref m (+ (* i 3) 1)))
9.39+ (* vz (aref m (+ (* i 3) 2))))))
9.40+ new))
9.41+
9.42+(defun m-rotate (degrees &key reverse)
9.43+ "Generate a rotation matrix."
9.44+ (let* ((matrix (id-matrix 3))
9.45+ (angle-rad (* (mod degrees 360) (/ PI 180)))
9.46+ (cos (coerce (cos angle-rad) 'single-float))
9.47+ (sin (coerce (sin angle-rad) 'single-float)))
9.48+ (setf (aref matrix 0) cos
9.49+ (aref matrix 1) (if reverse sin (- sin))
9.50+ (aref matrix 3) (if reverse (- sin) sin)
9.51+ (aref matrix 4) cos)
9.52+ matrix))
9.53+
9.54+(defun m-scale (x y)
9.55+ "Generate a scaling matrix."
9.56+ (let ((matrix (id-matrix 3)))
9.57+ (setf (aref matrix 0) (coerce x 'single-float)
9.58+ (aref matrix 4) (coerce y 'single-float))
9.59+ matrix))
9.60+
9.61+(defun m-translate (x y)
9.62+ "Generate a translation matrix."
9.63+ (let ((translatrix (id-matrix 3)))
9.64+ (setf (aref translatrix 2) (coerce x 'single-float)
9.65+ (aref translatrix 5) (coerce y 'single-float))
9.66+ translatrix))
9.67+
9.68+(defun m-skew (degrees &key (axis :x))
9.69+ "Generate a skew matrix along the :axis axis (:x or :y)."
9.70+ (let ((matrix (id-matrix 3))
9.71+ (angle-rad (* (mod degrees 360) (/ PI 180)))
9.72+ (idx (if (equal axis :x) 1 3)))
9.73+ (setf (aref matrix idx) (coerce (tan angle-rad) 'single-float))
9.74+ matrix))
9.75+
9.76+;;; VECTOR
9.77+(defun norm (v)
9.78+ "Calculate a vector norm."
9.79+ (expt (loop for x in v sum (expt x 2)) .5))
9.80+
9.81+(defun normalize (v)
9.82+ "Normalize a 2D vector"
9.83+ (let ((x (car v))
9.84+ (y (cadr v)))
9.85+ (let ((norm (norm v)))
9.86+ (list (/ x norm) (/ y norm)))))
9.87+
9.88+(defun dot-prod (v1 v2)
9.89+ "Give the dot product of two 2D vectors."
9.90+ (+ (* (car v1) (car v2))
9.91+ (* (cadr v1) (cadr v2))))
9.92+
9.93+;;; TRANSFORMATIONS
9.94+(defun parse-transform (transform)
9.95+ "Turn a transform(...) into an easily-parsable list structure."
9.96+ ;; convert "translate(-10,-20) scale(2) rotate(45) translate(5,10)" into
9.97+ ;; "(translate -10 -20) (scale 2) (rotate 45) (translate 5 10)"
9.98+ ;; (ie read-from-string'able)
9.99+ (let* ((transform (cl-ppcre::regex-replace-all "([a-z]+)\\(" transform "(\\1 "))
9.100+ (transform (cl-ppcre::regex-replace-all "," transform " ")))
9.101+ (read-from-string (format nil "( ~a )" transform))))
9.102+
9.103+(defun get-transformations (object groups)
9.104+ "Given an SVG object and a tree of groups, grab all transformations, starting
9.105+ from the top down, into a flat list so they can be applied sequentially."
9.106+ (let ((object-transform (getf object :transform))
9.107+ (object-group (getf object :group))
9.108+ (transformations nil))
9.109+ (labels ((traverse-groups (path groups)
9.110+ (dolist (group groups)
9.111+ (when (eql (car (getf group :group)) (car path))
9.112+ (let* ((groups (getf group :groups))
9.113+ (transform (getf group :transform))
9.114+ (transform (if (listp transform) (car transform) transform)))
9.115+ (when transform
9.116+ (push transform transformations))
9.117+ (when groups
9.118+ (traverse-groups (cdr path) groups)))))))
9.119+ (traverse-groups object-group groups))
9.120+ (when object-transform
9.121+ (push object-transform transformations))
9.122+ transformations))
9.123+
9.124+(defun get-matrix-from-transformation (transformation)
9.125+ "Given a transformation in list form (FN ARG1 ARG2 ...), turn it into a matrix
9.126+ which can be multipled to give the overall transformation for an object."
9.127+ (macrolet ((idx (var idx default)
9.128+ (let ((name (gensym)))
9.129+ `(let ((,name (nth ,idx ,var)))
9.130+ (if ,name ,name ,default)))))
9.131+ (let ((transformation (if (listp (car transformation))
9.132+ (car transformation)
9.133+ transformation)))
9.134+ (case (intern (write-to-string (car transformation)) :dat/svg)
9.135+ (matrix (vector (nth 1 transformation) (nth 3 transformation) (nth 5 transformation)
9.136+ (nth 2 transformation) (nth 4 transformation) (nth 6 transformation)
9.137+ 0 0 1))
9.138+ (translate (m-translate (nth 1 transformation) (idx transformation 2 0)))
9.139+ (scale (m-scale (nth 1 transformation) (idx transformation 2 0)))
9.140+ (rotate (let ((angle (nth 1 transformation))
9.141+ (center-x (idx transformation 2 0))
9.142+ (center-y (idx transformation 3 0)))
9.143+ (if (and (eq 0 center-x) (eq 0 center-y))
9.144+ ;; just rotate, no offset funny business
9.145+ (m-rotate angle)
9.146+ (mat* (mat* (m-translate center-x center-y) (m-rotate angle)) (m-translate (- center-x) (- center-y))))))
9.147+ (skewx (m-skew (nth 1 transformation) :axis :x))
9.148+ (skewy (m-skew (nth 1 transformation) :axis :y))))))
9.149+
9.150+(defun apply-transformations (points object groups &key scale)
9.151+ "Apply all transformations for an object, starting from its top-level group
9.152+ and working down to the object itself."
9.153+ (let ((transformations (get-transformations object groups))
9.154+ (matrix (id-matrix 3))
9.155+ (trans-points nil))
9.156+ (dolist (transform transformations)
9.157+ (setf matrix (mat* (get-matrix-from-transformation transform) matrix)))
9.158+ (when scale
9.159+ (setf matrix (mat* (m-scale (car scale) (cadr scale)) matrix)))
9.160+ (loop for p across points do
9.161+ (push (butlast (matv* matrix (append p '(1)))) trans-points))
9.162+ (values (reverse trans-points)
9.163+ matrix)))
9.164+;;; PATHS
9.165+(define-condition unsupported-path-command (error)
9.166+ ((text :initarg :text :reader text))
9.167+ (:documentation "Thrown when an unsupported action/feature is parsed in a path."))
9.168+
9.169+(defun points-close-equal-p (point1 point2 &key (precision 10))
9.170+ "Determine if two points are (about) the same. Yes, this is open to
9.171+ interpretation, which is why it takes a precision argument =]."
9.172+ (flet ((round-point (point)
9.173+ (mapcar (lambda (x) (/ (floor (* x precision)) precision)) point)))
9.174+ (equal (round-point point1) (round-point point2))))
9.175+
9.176+(defun replace-char (char rep str)
9.177+ "Replace all instances of char with rep in str (non-destructive)."
9.178+ (let ((new-str (make-string (length str))))
9.179+ (loop for i from 0
9.180+ for c across str do
9.181+ (setf (aref new-str i) (if (eq c char)
9.182+ rep
9.183+ c)))
9.184+ new-str))
9.185+
9.186+(defmacro cmd-repeat (args-and-count &body body)
9.187+ "Some commands can repeat values with the command, namely the curve commands:
9.188+ c,1,2,4,4,5,5 c,8,8,3,4,3,1
9.189+ can be written as
9.190+ c,1,2,4,4,5,5,8,8,3,4,3,1
9.191+ yay. This macro helps alleviate some of the issues caused by this wonderful
9.192+ feature in the get-points-from-path function."
9.193+ (let ((i (gensym))
9.194+ (a (gensym))
9.195+ (args (car args-and-count))
9.196+ (count (cadr args-and-count)))
9.197+ `(dotimes (,i (floor (/ (length ,args) ,count)))
9.198+ ,@body
9.199+ (setf cur-x (car cur-point)
9.200+ cur-y (cadr cur-point))
9.201+ (dotimes (,a ,count)
9.202+ (setf ,args (cdr ,args))))))
9.203+(defun get-points-from-path (str-data &key (curve-resolution 10))
9.204+ "Given a string describing an SVG path, do our best to retrieve points along
9.205+ that path. Bezier curves are approximated as accurately as needed (defined by
9.206+ :curve-resolution).
9.207+
9.208+ If the path generates an arc between x1,y1 and x2,y2, we just ignore the whole
9.209+ arc thing and set x2,y2 as the next point in the path.
9.210+
9.211+ If Z/z ends the path in the middle, we silently return the current set of
9.212+ points without continuing the path. The idea here is we are generating
9.213+ polygons so breaks or cutouts are not acceptable."
9.214+ (let ((commands (print (split "(?=[a-zA-Z])" str-data)))
9.215+ (scanner-empty-p (cl-ppcre:create-scanner (concatenate 'string "[" *whitespaces* "]") :multi-line-mode t))
9.216+ (points nil)
9.217+ (parts nil)
9.218+ (first-point nil)
9.219+ (cur-point '(0 0))
9.220+ (last-anchor nil)
9.221+ (disconnected nil))
9.222+ (dolist (cmd-str commands)
9.223+ ;; this (let) splits the command from "M-113-20" to
9.224+ ;; ("M" "-113" "-20")
9.225+ (let* ((cmd-parts (cl-ppcre:split "( |,|(?<=[A-Za-z])|(?=\-))" cmd-str))
9.226+ (cmd (aref (car cmd-parts) 0))
9.227+ ;(forget (format t "cmd: ~s~%" cmd-parts))
9.228+ (args (remove-if #'null (mapcar (lambda (a)
9.229+ (if (cl-ppcre:scan scanner-empty-p a)
9.230+ nil
9.231+ (read-from-string a)))
9.232+ (cdr cmd-parts))))
9.233+ (cur-x (car cur-point))
9.234+ (cur-y (cadr cur-point)))
9.235+ ;; process the commands (http://www.w3.org/TR/SVG/paths.html)
9.236+ (case (if (eq cmd #\z)
9.237+ (aref (string-upcase cmd) 0)
9.238+ cmd)
9.239+ (#\M
9.240+ (cmd-repeat (args 2)
9.241+ (setf cur-point args)
9.242+ (push cur-point points)))
9.243+ (#\m
9.244+ (cmd-repeat (args 2)
9.245+ (setf cur-point (list (+ cur-x (car args))
9.246+ (+ cur-y (cadr args))))
9.247+ (push cur-point points)))
9.248+ (#\L
9.249+ (cmd-repeat (args 2)
9.250+ (setf cur-point args)
9.251+ (push cur-point points)))
9.252+ (#\l
9.253+ (cmd-repeat (args 2)
9.254+ (setf cur-point (list (+ cur-x (car args))
9.255+ (+ cur-y (cadr args))))
9.256+ (push cur-point points)))
9.257+ (#\H
9.258+ (cmd-repeat (args 1)
9.259+ (setf (car cur-point) (car args))
9.260+ (push cur-point points)))
9.261+ (#\h
9.262+ (cmd-repeat (args 1)
9.263+ (setf (car cur-point) (+ cur-x (car args)))
9.264+ (push cur-point points)))
9.265+ (#\V
9.266+ (cmd-repeat (args 1)
9.267+ (setf (cadr cur-point) (car args))
9.268+ (push cur-point points)))
9.269+ (#\v
9.270+ (cmd-repeat (args 1)
9.271+ (setf (cadr cur-point) (+ cur-y (car args)))
9.272+ (push cur-point points)))
9.273+ (#\C
9.274+ (cmd-repeat (args 6)
9.275+ (let ((x1 (car args))
9.276+ (y1 (cadr args))
9.277+ (x2 (nth 2 args))
9.278+ (y2 (nth 3 args))
9.279+ (x (nth 4 args))
9.280+ (y (nth 5 args)))
9.281+ (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)
9.282+ last-anchor (list x2 y2)
9.283+ cur-point (list x y)))))
9.284+ (#\c
9.285+ (cmd-repeat (args 6)
9.286+ (let ((x1 (+ (car args) cur-x))
9.287+ (y1 (+ (cadr args) cur-y))
9.288+ (x2 (+ (nth 2 args) cur-x))
9.289+ (y2 (+ (nth 3 args) cur-y))
9.290+ (x (+ (nth 4 args) cur-x))
9.291+ (y (+ (nth 5 args) cur-y)))
9.292+ (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)
9.293+ last-anchor (list x2 y2)
9.294+ cur-point (list x y)))))
9.295+ (#\S
9.296+ (cmd-repeat (args 4)
9.297+ (let ((x1 (+ cur-x (- cur-x (car last-anchor))))
9.298+ (y1 (+ cur-y (- cur-y (cadr last-anchor))))
9.299+ (x2 (car args))
9.300+ (y2 (cadr args))
9.301+ (x (nth 2 args))
9.302+ (y (nth 3 args)))
9.303+ (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)
9.304+ last-anchor (list x2 y2)
9.305+ cur-point (list x y)))))
9.306+ (#\s
9.307+ (cmd-repeat (args 4)
9.308+ (let ((x1 (+ cur-x (- cur-x (car last-anchor))))
9.309+ (y1 (+ cur-y (- cur-y (cadr last-anchor))))
9.310+ (x2 (+ (car args) cur-x))
9.311+ (y2 (+ (cadr args) cur-y))
9.312+ (x (+ (nth 2 args) cur-x))
9.313+ (y (+ (nth 3 args) cur-y)))
9.314+ (setf points (append (bezier-cubic cur-x cur-y x y x1 y1 x2 y2 :resolution curve-resolution) points)
9.315+ last-anchor (list x2 y2)
9.316+ cur-point (list x y)))))
9.317+ (#\Q
9.318+ (cmd-repeat (args 4)
9.319+ (let ((x1 (car args))
9.320+ (y1 (cadr args))
9.321+ (x (nth 2 args))
9.322+ (y (nth 3 args)))
9.323+ (setf points (append (bezier-quadratic cur-x cur-y x y x1 y1 :resolution curve-resolution) points)
9.324+ last-anchor (list x1 y1)
9.325+ cur-point (list x y)))))
9.326+ (#\q
9.327+ (cmd-repeat (args 4)
9.328+ (let ((x1 (+ (car args) cur-x))
9.329+ (y1 (+ (cadr args) cur-y))
9.330+ (x (+ (nth 2 args) cur-x))
9.331+ (y (+ (nth 3 args) cur-y)))
9.332+ (setf points (append (bezier-quadratic cur-x cur-y x y x1 y1 :resolution curve-resolution) points)
9.333+ last-anchor (list x1 y1)
9.334+ cur-point (list x y)))))
9.335+ (#\T
9.336+ (cmd-repeat (args 2)
9.337+ (let ((x1 (+ cur-x (- cur-x (car last-anchor))))
9.338+ (y1 (+ cur-y (- cur-y (cadr last-anchor))))
9.339+ (x (car args))
9.340+ (y (cadr args)))
9.341+ (setf points (append (bezier-quadratic cur-x cur-y x y x1 y1 :resolution curve-resolution) points)
9.342+ last-anchor (list x1 y1)
9.343+ cur-point (list x y)))))
9.344+ (#\t
9.345+ (cmd-repeat (args 2)
9.346+ (let ((x1 (+ cur-x (- cur-x (car last-anchor))))
9.347+ (y1 (+ cur-y (- cur-y (cadr last-anchor))))
9.348+ (x (+ (car args) cur-x))
9.349+ (y (+ (cadr args) cur-y)))
9.350+ (setf points (append (bezier-quadratic cur-x cur-y x y x1 y1 :resolution curve-resolution) points)
9.351+ last-anchor (list x1 y1)
9.352+ cur-point (list x y)))))
9.353+ (#\A
9.354+ (cmd-repeat (args 7)
9.355+ (let ((rx (car args))
9.356+ (ry (cadr args))
9.357+ (x-rot (caddr args))
9.358+ (large-arc (cadddr args))
9.359+ (sweep-flag (cadr (cdddr args)))
9.360+ (x1 (car cur-point))
9.361+ (y1 (cadr cur-point))
9.362+ (x2 (+ (caddr (cdddr args)) (car cur-point)))
9.363+ (y2 (+ (cadddr (cdddr args)) (cadr cur-point))))
9.364+ (setf points (append (elliptical-arc x1 y1 x2 y2 rx ry x-rot large-arc sweep-flag :resolution curve-resolution) points)
9.365+ cur-point (list x2 y2)))))
9.366+ (#\a
9.367+ (cmd-repeat (args 7)
9.368+ (let ((rx (car args))
9.369+ (ry (cadr args))
9.370+ (x-rot (caddr args))
9.371+ (large-arc (cadddr args))
9.372+ (sweep-flag (cadr (cdddr args)))
9.373+ (x1 (car cur-point))
9.374+ (y1 (cadr cur-point))
9.375+ (x2 (+ (caddr (cdddr args)) (car cur-point)))
9.376+ (y2 (+ (cadddr (cdddr args)) (cadr cur-point))))
9.377+ (setf points (append (elliptical-arc x1 y1 x2 y2 rx ry x-rot large-arc sweep-flag :resolution curve-resolution) points)
9.378+ cur-point (list x2 y2)))))
9.379+ (#\Z
9.380+ (push (coerce (reverse (if (points-close-equal-p (car points) first-point)
9.381+ (cdr points)
9.382+ points)) 'vector) parts)
9.383+ (setf points nil))))
9.384+ (when (= (length points) 1)
9.385+ (setf first-point (car points))))
9.386+ (when (not (zerop (length points)))
9.387+ ;; we have unfinished points. add them to the part list
9.388+ (setf disconnected t)
9.389+ (push (coerce (reverse (if (points-close-equal-p (car points) first-point)
9.390+ (cdr points)
9.391+ points)) 'vector) parts))
9.392+ (values (reverse parts) disconnected)))
9.393+
9.394+(defun bezier-cubic (x1 y1 x2 y2 ax1 ay1 ax2 ay2 &key (resolution 10))
9.395+ "Sample resolution points off of a cubic bezier curve from (x1,y1) to (x2,y2)
9.396+ using anchor points (ax1,ay1) (ax2,ay2)."
9.397+ (let ((points nil))
9.398+ (flet ((cubic (t-val p0 p1 p2 p3)
9.399+ (+ (* (expt (- 1 t-val) 3) p0)
9.400+ (* 3 (expt (- 1 t-val) 2) t-val p1)
9.401+ (* 3 (- 1 t-val) (expt t-val 2) p2)
9.402+ (* (expt t-val 3) p3))))
9.403+ (dotimes (i resolution)
9.404+ (let ((t-val (* (1+ i) (/ 1 resolution))))
9.405+ (push (list (cubic t-val x1 ax1 ax2 x2)
9.406+ (cubic t-val y1 ay1 ay2 y2))
9.407+ points))))
9.408+ points))
9.409+
9.410+(defun bezier-quadratic (x1 y1 x2 y2 ax1 ay1 &key (resolution 10))
9.411+ "Sample resolution points off of a quadratic bezier curve from (x1,y1) to
9.412+ (x2,y2) using anchor points (ax1,ay1) (ax2,ay2)."
9.413+ (let ((points nil))
9.414+ (flet ((quadratic (t-val p0 p1 p2)
9.415+ (+ (* (expt (- 1 t-val) 2) p0)
9.416+ (* 2 (- 1 t-val) t-val p1)
9.417+ (* (expt t-val 2) p2))))
9.418+ (dotimes (i resolution)
9.419+ (let ((t-val (* (1+ i) (/ 1 resolution))))
9.420+ (push (list (quadratic t-val x1 ax1 x2)
9.421+ (quadratic t-val y1 ay1 y2)) points))))
9.422+ points))
9.423+
9.424+(defun elliptical-arc (x1 y1 x2 y2 rx ry x-rotation large-arc-flag sweep-flag &key (resolution 10))
9.425+ "Calculate an arc in a path. Yuck."
9.426+ (let ((rot-mat-i (m-rotate x-rotation :reverse t))
9.427+ (rot-mat (m-rotate x-rotation)))
9.428+ ;; calculate a bunch of crap, mainly ellipse center x,y
9.429+ (let* ((xy-i (matv* rot-mat-i (list (/ (- x1 x2) 2)
9.430+ (/ (- y1 y2) 2))))
9.431+ (x-i (car xy-i))
9.432+ (y-i (cadr xy-i))
9.433+ (rx2 (expt rx 2))
9.434+ (ry2 (expt ry 2))
9.435+ (x-i2 (expt x-i 2))
9.436+ (y-i2 (expt y-i 2))
9.437+ (cxy-m (expt (/ (- (* rx2 ry2) (* rx2 y-i2) (* ry2 x-i2))
9.438+ (+ (* rx2 y-i2) (* rx2 x-i2)))
9.439+ .5))
9.440+ (cxy-m (if (eq large-arc-flag sweep-flag)
9.441+ (- cxy-m)
9.442+ cxy-m))
9.443+ (cx-i (* cxy-m (/ (* rx y-i) ry)))
9.444+ (cy-i (* cxy-m (/ (* ry x-i) (- rx))))
9.445+ (cxy (matv* rot-mat (list cx-i cy-i)))
9.446+ (cx (+ (car cxy) (/ (+ x1 x2) 2)))
9.447+ (cy (+ (cadr cxy) (/ (+ y1 y2) 2))))
9.448+ (flet ((angle (v1 v2)
9.449+ (let ((x1 (car v1))
9.450+ (y1 (cadr v1))
9.451+ (x2 (car v2))
9.452+ (y2 (cadr v2)))
9.453+ (let ((sign (if (< 0 (- (* x1 y2) (* y1 x2)))
9.454+ 1
9.455+ -1)))
9.456+ (* sign (acos (/ (dot-prod v1 v2)
9.457+ (* (norm v1) (norm v2)))))))))
9.458+ ;; calculate the start/delta angles
9.459+ (let ((theta-1 (angle (list 1 0) (list (/ (- x-i cx-i) rx)
9.460+ (/ (- y-i cy-i) ry))))
9.461+ (theta-delta (angle (list (/ (- x-i cx-i) rx)
9.462+ (/ (- y-i cy-i) ry))
9.463+ (list (/ (- (- x-i) cx-i) rx)
9.464+ (/ (- (- y-i) cy-i) ry)))))
9.465+ (let ((theta-step (/ theta-delta resolution))
9.466+ (points nil))
9.467+ ;; create our points for the ellipse. if this were a true
9.468+ ;; implementation, we'd do radii correction such that x2,y2 always
9.469+ ;; fall ON the ellipse path, but i truly do not care enough to
9.470+ ;; bother. if your SVG generator sucks, take it up with them, or
9.471+ ;; better yet do the proper calculations and issue a pull request.
9.472+ (dotimes (i resolution)
9.473+ (let ((angle (+ theta-1 (* theta-step i))))
9.474+ (let ((xy (matv* rot-mat (list (* rx (cos angle))
9.475+ (* ry (sin angle))))))
9.476+ (push (list (+ (car xy) cx)
9.477+ (+ (cadr xy) cy)) points))))
9.478+ ;; get the last point on there.
9.479+ (push (list x2 y2) points)
9.480+ (reverse points)))))))
9.481+
9.482+;;; SVG
9.483+(define-condition not-an-object (simple-condition) ())
9.484+
9.485+(defun get-points-from-ellipse (x y rx ry &key (curve-resolution 20))
9.486+ "Calculate curve-resolution points along an ellipse. Can be used for circles
9.487+ too (when rx == ry)."
9.488+ (let ((points (make-array curve-resolution)))
9.489+ (dotimes (i curve-resolution)
9.490+ (let ((rad (* i (/ (* 2 PI) curve-resolution))))
9.491+ (setf (aref points i)
9.492+ (list (coerce (+ x (* (cos rad) rx)) 'single-float)
9.493+ (coerce (+ y (* (sin rad) ry)) 'single-float)))))
9.494+ points))
9.495+
9.496+(defmacro with-plist-string-reads (plist bindings &body body)
9.497+ "Helper macro to make convert-to-points much more readable. Basically wraps
9.498+ around reading values from a string in a plist and binding the result to a
9.499+ variable:
9.500+
9.501+ (with-plist-string-reads my-plist ((x :x) (y :y))
9.502+ (+ x y))
9.503+
9.504+ Expands to:
9.505+
9.506+ (let ((x (read-from-string (getf my-plist :x)))
9.507+ (y (read-from-string (getf my-plist :y))))
9.508+ (+ x y))
9.509+
9.510+ Much cleaner."
9.511+ `(let ,(loop for binding in bindings collect
9.512+ (list (car binding) `(read-from-string (getf ,plist ,(cadr binding)))))
9.513+ ,@body))
9.514+
9.515+(defun convert-to-points (obj &key (curve-resolution 10))
9.516+ "Take an object loaded from and SVG file (most likely using parse-svg-nodes)
9.517+ and turn it into a set of points describing a polygon. Curves are
9.518+ approximated using :curve-resolution. The higher the resolution, the more
9.519+ accurate the curve will be. This works for paths with bezier curves as well
9.520+ as ellipses and circles."
9.521+ (case (intern (string-upcase (getf obj :type)) :dat/svg)
9.522+ (rect
9.523+ (with-plist-string-reads obj ((x :x) (y :y) (w :width) (h :height))
9.524+ (list :points (list (vector (list x y)
9.525+ (list (+ x w) y)
9.526+ (list (+ x w) (+ y h))
9.527+ (list x (+ y h)))))))
9.528+ (polygon
9.529+ (let* ((pairs (split-sequence:split-sequence #\space (getf obj :points)))
9.530+ (points (loop for pair in pairs
9.531+ if (find #\, pair) collect (progn (setf (aref pair (search "," pair)) #\space)
9.532+ (read-from-string (format nil "(~a)" pair))))))
9.533+ (list :points (list (coerce points 'vector)))))
9.534+ (path
9.535+ (multiple-value-bind (parts disconnected)
9.536+ (get-points-from-path (getf obj :d) :curve-resolution curve-resolution)
9.537+ (list :points parts :meta (list :disconnected disconnected))))
9.538+ (ellipse
9.539+ (with-plist-string-reads obj ((x :cx) (y :cy) (rx :rx) (ry :ry))
9.540+ (list :points (list (get-points-from-ellipse x y rx ry :curve-resolution curve-resolution)))))
9.541+ (circle
9.542+ (with-plist-string-reads obj ((x :cx) (y :cy) (r :r))
9.543+ (list :points (list (get-points-from-ellipse x y r r :curve-resolution curve-resolution)))))
9.544+ (t
9.545+ (error 'not-an-object))))
9.546+
9.547+(defun get-node-attr (node attr-name)
9.548+ "Given a node, get the attribute stored under attr-name."
9.549+ (cadr (dat/xml::find-attrib attr-name node)))
9.550+
9.551+(defun parse-svg-nodes (nodes &key parent-group (next-id 0) save-attributes (group-id-attribute-name "id"))
9.552+ "Given an SVG doc read via dat/xml:parse, return two things:
9.553+
9.554+ 1. A list of plist objects describing ALL the objects found in the SVG file.
9.555+ Each object stores the group it's part of along with its attributes and
9.556+ transformations.
9.557+ 2. A list of plist objects describing ALL the groups found, each storing its
9.558+ group id (created if not explicit) and any transformations that group has.
9.559+
9.560+ The idea is that given this data, we can easily generate polygons for each
9.561+ object and then apply transformations to it starting with its top-level group
9.562+ and working down to the object's transformations itself."
9.563+ (let ((objs nil)
9.564+ (groups nil))
9.565+ (loop for node in (xml-node-children nodes)
9.566+ do (let ((tag (xml-node-name node)))
9.567+ (if (equal tag "g")
9.568+ (let* ((gid (get-node-attr node group-id-attribute-name))
9.569+ (gid (if gid gid (get-node-attr node "id")))
9.570+ (gid (list (if gid gid (incf next-id))))
9.571+ (full-gid (if parent-group
9.572+ (append parent-group gid)
9.573+ gid)))
9.574+ (multiple-value-bind (sub-nodes sub-groups) (parse-svg-nodes node
9.575+ :parent-group full-gid
9.576+ :next-id next-id
9.577+ :save-attributes save-attributes
9.578+ :group-id-attribute-name group-id-attribute-name)
9.579+ (setf objs (append sub-nodes objs))
9.580+ (push (list :group gid :transform (parse-transform (get-node-attr node "transform")) :groups sub-groups) groups)))
9.581+ (let* ((gid parent-group)
9.582+ (obj (list :type tag :group gid))
9.583+ (tagsym (intern (string-upcase tag) :dat/svg))
9.584+ (attrs (append (case tagsym
9.585+ (rect (list "x" "y" "width" "height"))
9.586+ (polygon (list "points"))
9.587+ (path (list "d"))
9.588+ (ellipse (list "cx" "cy" "rx" "ry"))
9.589+ (circle (list "cx" "cy" "r"))
9.590+ (t nil))
9.591+ save-attributes)))
9.592+ (when attrs
9.593+ (push (append obj (loop for attr in (append attrs (list "transform" "fill" "style" "opacity"))
9.594+ for val = (get-node-attr node attr)
9.595+ for parsed = (if (and val (equal attr "transform")) (parse-transform val) val)
9.596+ if parsed append (list (read-from-string (format nil ":~a" attr)) parsed)))
9.597+ objs))))))
9.598+ (values objs groups)))
9.599+
9.600+(defun file-contents (path)
9.601+ "Sucks up an entire file from PATH into a freshly-allocated string,
9.602+ returning two values: the string and the number of bytes read."
9.603+ (with-open-file (s path)
9.604+ (let* ((len (file-length s))
9.605+ (data (make-string len)))
9.606+ (values data (read-sequence data s)))))
9.607+
9.608+(defun parse-svg-string (svg-str &key (curve-resolution 10) scale save-attributes (group-id-attribute-name "id"))
9.609+ "Parses an SVG string, creating the nodes and groups from the SVG, then
9.610+ converts each object into a set of points using the data in that object and
9.611+ the transformations from the groups the object belongs to (and the object's
9.612+ own transformations).
9.613+
9.614+ SVG object curve resolutions can be set via :curve-resolution (the higher the
9.615+ value, the more accurate curves are)."
9.616+ (multiple-value-bind (nodes groups)
9.617+ (parse-svg-nodes (xml-parse svg-str :quash-errors nil) :save-attributes save-attributes :group-id-attribute-name group-id-attribute-name)
9.618+ (remove-if
9.619+ 'null
9.620+ (mapcar (lambda (node)
9.621+ (handler-case
9.622+ (let* ((points-and-meta (convert-to-points node :curve-resolution curve-resolution))
9.623+ (points-and-holes (getf points-and-meta :points))
9.624+ (points (apply-transformations (car points-and-holes) node groups :scale scale))
9.625+ (holes nil))
9.626+ (dolist (hole (cdr points-and-holes))
9.627+ (push (coerce (apply-transformations hole node groups :scale scale) 'vector) holes))
9.628+ (append node (list :point-data (coerce points 'vector) :holes holes :meta (getf points-and-meta :meta))))
9.629+ (not-an-object ()
9.630+ nil)))
9.631+ nodes))))
9.632+
9.633+(defun parse-svg-file (filename &key (curve-resolution 10) scale save-attributes (group-id-attribute-name "id"))
9.634+ "Simple wrapper around parse-svg-string.
9.635+
9.636+ SVG object curve resolutions can be set via :curve-resolution (the higher the
9.637+ value, the more accurate curves are)."
9.638+ (parse-svg-string (file-contents filename) :curve-resolution curve-resolution :scale scale :save-attributes save-attributes :group-id-attribute-name group-id-attribute-name))
10.1--- a/lisp/lib/packy/db.lisp Sun Mar 17 22:21:29 2024 -0400
10.2+++ b/lisp/lib/packy/db.lisp Mon Mar 18 21:47:33 2024 -0400
10.3@@ -2,13 +2,12 @@
10.4
10.5 (defclass packy-database (database) ()
10.6 (:default-initargs
10.7- :db (make-rdb :name "packy")))
10.8+ :db (make-rdb "packy" (default-rdb-opts) #())))
10.9
10.10 (defmethod make-db ((engine (eql :packy)) &rest initargs &key &allow-other-keys)
10.11 (apply #'make-instance 'packy-database initargs))
10.12
10.13 (defmethod connect-db ((db packy-database) &key &allow-other-keys)
10.14- (declare (ignorable initargs))
10.15 (with-slots (db) db
10.16 (open-db db)))
10.17
11.1--- a/lisp/lib/skel/pkg.lisp Sun Mar 17 22:21:29 2024 -0400
11.2+++ b/lisp/lib/skel/pkg.lisp Mon Mar 18 21:47:33 2024 -0400
11.3@@ -122,6 +122,5 @@
11.4
11.5 ;;; Extensions
11.6 (defpackage :skel/asdf
11.7- (:use :cl :std :skel :asdf/interface)
11.8- (:shadow :circular-dependency)
11.9+ (:use :cl :std :skel)
11.10 (:export))
12.1--- a/rust/Cargo.toml Sun Mar 17 22:21:29 2024 -0400
12.2+++ b/rust/Cargo.toml Mon Mar 18 21:47:33 2024 -0400
12.3@@ -14,4 +14,5 @@
12.4 tokio-util = "0.7.10"
12.5 tokio-stream = "0.1.14"
12.6 serde = "1.0.197"
12.7-log = "0.4.20"
12.8\ No newline at end of file
12.9+log = "0.4.20"
12.10+bindgen = "0.66.1"
12.11\ No newline at end of file
13.1--- a/rust/lib/obj/src/id.rs Sun Mar 17 22:21:29 2024 -0400
13.2+++ b/rust/lib/obj/src/id.rs Mon Mar 18 21:47:33 2024 -0400
13.3@@ -3,7 +3,7 @@
13.4 //! primitive ID types.
13.5
13.6 pub use hash::Id;
13.7-pub use rusty_ulid::{self, Ulid};
13.8+pub use rusty_ulid::Ulid;
13.9 use std::{fmt, str::FromStr};
13.10 pub use uuid::Uuid;
13.11 /// Identity trait
14.1--- a/rust/sys/btrfsutil/Cargo.toml Sun Mar 17 22:21:29 2024 -0400
14.2+++ b/rust/sys/btrfsutil/Cargo.toml Mon Mar 18 21:47:33 2024 -0400
14.3@@ -4,4 +4,4 @@
14.4 version = "0.1.0"
14.5 edition = "2021"
14.6 [build-dependencies]
14.7-bindgen = "0.66.1"
14.8+bindgen = { workspace = true }
15.1--- a/rust/sys/sbcl/Cargo.toml Sun Mar 17 22:21:29 2024 -0400
15.2+++ b/rust/sys/sbcl/Cargo.toml Mon Mar 18 21:47:33 2024 -0400
15.3@@ -4,3 +4,5 @@
15.4 authors.workspace = true
15.5 edition.workspace = true
15.6 [dependencies]
15.7+libc = "0.2.153"
15.8+libloading = "0.8.3"
16.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
16.2+++ b/rust/sys/sbcl/src/build.rs Mon Mar 18 21:47:33 2024 -0400
16.3@@ -0,0 +1,4 @@
16.4+fn main() {
16.5+ println!("cargo:rustc-link-search=native=/usr/local/lib/");
16.6+ println!("cargo:rustc-link-lib=dylib=sbcl");
16.7+}
17.1--- a/rust/sys/sbcl/src/lib.rs Sun Mar 17 22:21:29 2024 -0400
17.2+++ b/rust/sys/sbcl/src/lib.rs Mon Mar 18 21:47:33 2024 -0400
17.3@@ -1,14 +1,25 @@
17.4-pub fn add(left: usize, right: usize) -> usize {
17.5- left + right
17.6-}
17.7+//! lib.rs --- sbcl sys
17.8+#![allow(non_upper_case_globals)]
17.9+#![allow(non_camel_case_types)]
17.10+#![allow(non_snake_case)]
17.11+
17.12+use std::ffi::c_char;
17.13
17.14 #[cfg(test)]
17.15 mod tests {
17.16 use super::*;
17.17-
17.18+ use libloading::{Library,Symbol};
17.19 #[test]
17.20- fn it_works() {
17.21- let result = add(2, 2);
17.22- assert_eq!(result, 4);
17.23+ fn lisp_version_test() {
17.24+ unsafe {
17.25+ let lib = Library::new("/usr/local/lib/libsbcl.so").unwrap();
17.26+ let initialize_lisp = lib.get::<Symbol<extern "C" fn() -> std::ffi::c_int>>(b"initialize_lisp")
17.27+ .unwrap();
17.28+ initialize_lisp();
17.29+ // assert_eq!(res,0);
17.30+ //let lisp_version = lib.get::<Symbol<extern "C" fn()->&'static str>>(b"lisp_version")
17.31+ //.unwrap();
17.32+ //assert_eq!(lisp_version(), "2.4.2+");
17.33+ }
17.34 }
17.35 }
18.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
18.2+++ b/rust/sys/sbcl/wrapper.lisp Mon Mar 18 21:47:33 2024 -0400
18.3@@ -0,0 +1,5 @@
18.4+(define-alien-callable lisp-version c-string ()
18.5+ (make-alien-string (lisp-implementation-version)))
18.6+
18.7+(sb-ext:save-lisp-and-die "alien.core" :callable-exports '("lisp_version"))
18.8+
