--- a/Makefile Sat Apr 30 20:20:04 2016 +0000
+++ b/Makefile Sat Apr 30 20:42:21 2016 +0000
@@ -1,4 +1,4 @@
.PHONY:
quickutils.lisp: make-quickutils.lisp
- sbcl --noinform --load make-quickutils.lisp --eval '(quit)'
+ sbcl-rlwrap --noinform --load make-quickutils.lisp --eval '(quit)'
--- a/make-quickutils.lisp Sat Apr 30 20:20:04 2016 +0000
+++ b/make-quickutils.lisp Sat Apr 30 20:42:21 2016 +0000
@@ -7,5 +7,6 @@
:while
:ensure-boolean
:with-gensyms
+ :once-only
)
:package "CODING-MATH.QUICKUTILS")
--- a/package.lisp Sat Apr 30 20:20:04 2016 +0000
+++ b/package.lisp Sat Apr 30 20:42:21 2016 +0000
@@ -67,7 +67,8 @@
#:vec-sub!
#:vec-mul!
#:vec-div!
- #:vec-to-string))
+ #:vec-to-string
+ #:with-vec))
(defpackage #:coding-math.particles
(:use
--- a/quickutils.lisp Sat Apr 30 20:20:04 2016 +0000
+++ b/quickutils.lisp Sat Apr 30 20:42:21 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SWITCH :WHILE :ENSURE-BOOLEAN :WITH-GENSYMS) :ensure-package T :package "CODING-MATH.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SWITCH :WHILE :ENSURE-BOOLEAN :WITH-GENSYMS :ONCE-ONLY) :ensure-package T :package "CODING-MATH.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "CODING-MATH.QUICKUTILS")
@@ -15,7 +15,8 @@
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :STRING-DESIGNATOR
:WITH-GENSYMS :EXTRACT-FUNCTION-NAME
- :SWITCH :UNTIL :WHILE :ENSURE-BOOLEAN))))
+ :SWITCH :UNTIL :WHILE :ENSURE-BOOLEAN
+ :MAKE-GENSYM-LIST :ONCE-ONLY))))
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
@@ -166,7 +167,54 @@
(and x t))
(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)
(export '(define-constant switch eswitch cswitch while ensure-boolean
- with-gensyms with-unique-names)))
+ with-gensyms with-unique-names once-only)))
;;;; END OF quickutils.lisp ;;;;
--- a/src/main.lisp Sat Apr 30 20:20:04 2016 +0000
+++ b/src/main.lisp Sat Apr 30 20:42:21 2016 +0000
@@ -1,8 +1,8 @@
(in-package #:coding-math)
-(declaim (optimize (speed 1)
+(declaim (optimize (speed 3)
(safety 1)
- (debug 1)))
+ (debug 0)))
;;;; Config
(defparameter *width* 600)
--- a/src/vectors.lisp Sat Apr 30 20:20:04 2016 +0000
+++ b/src/vectors.lisp Sat Apr 30 20:42:21 2016 +0000
@@ -1,12 +1,15 @@
(in-package #:coding-math.vectors)
-(defclass vec ()
- ((x :type 'real :initarg :x :accessor vec-x)
- (y :type 'real :initarg :y :accessor vec-y)))
+
+(declaim (inline vec-x vec-y))
+(defstruct (vec
+ (:constructor make-vec
+ (&optional (x 0) (y 0)))
+ (:type vector))
+ (x 0 :type real)
+ (y 0 :type real))
-(defun make-vec (&optional (x 0) (y 0))
- (make-instance 'vec :x x :y y))
(defun make-vec-md (magnitude angle)
(let ((v (make-vec 0 0)))
@@ -18,13 +21,20 @@
(make-vec-md magnitude angle))
+(defmacro with-vec (bindings vec &body body)
+ (once-only (vec)
+ `(let ((,(first bindings) (vec-x ,vec))
+ (,(second bindings) (vec-y ,vec)))
+ ,@body)))
+
+
(defun vec-magnitude (vec)
- (with-slots (x y) vec
+ (with-vec (x y) vec
(sqrt (+ (* x x)
(* y y)))))
(defun vec-angle (vec)
- (with-slots (x y) vec
+ (with-vec (x y) vec
(atan y x)))
(defun vec-direction (vec)
@@ -33,9 +43,8 @@
(defun (setf vec-angle) (angle vec)
(let ((magnitude (vec-magnitude vec)))
- (with-slots (x y) vec
- (setf x (* magnitude (cos angle)))
- (setf y (* magnitude (sin angle)))))
+ (setf (vec-x vec) (* magnitude (cos angle)))
+ (setf (vec-y vec) (* magnitude (sin angle))))
angle)
(defun (setf vec-direction) (angle vec)
@@ -43,9 +52,8 @@
(defun (setf vec-magnitude) (magnitude vec)
(let ((angle (vec-angle vec)))
- (with-slots (x y) vec
- (setf x (* magnitude (cos angle)))
- (setf y (* magnitude (sin angle)))))
+ (setf (vec-x vec) (* magnitude (cos angle)))
+ (setf (vec-y vec) (* magnitude (sin angle))))
magnitude)