Commit 6b81884c authored by Steven Shi An's avatar Steven Shi An
Browse files

Initial import
parent 0515654e
Loading
Loading
Loading
Loading

clean-cmucl.sh

deleted100644 → 0
+0 −1
Original line number Diff line number Diff line
rm -f *.x86f steven/*.x86f steven/raytracer/*.x86f

install.sh

deleted100644 → 0
+0 −4
Original line number Diff line number Diff line
echo Getting dependencies via anonymous CVS..
cvs -z3 -d :pserver:anonymous:anonymous@common-lisp.net:/project/imago/cvsroot co imago
cvs -z3 -d :pserver:anonymous:anonymous@common-lisp.net:/project/zlib/cvsroot co zlib
cvs -z3 -d :pserver:anonymous@cvs.sourceforge.net:/cvsroot/cclan co -P asdf

steven/3dmath.lisp

deleted100644 → 0
+0 −312
Original line number Diff line number Diff line
(in-package :an.steven.3dmath)

;;; TODO - can i not define each func three times..like not have three v-*'s?  Use macros somehow?

;; Vector 3D
(defconstant +num-vector-dimensions+ 3)

(defun make-vector (x y z)
  (vector x y z))
(defmacro v-x (v) `(aref ,v 0))
(defmacro v-y (v) `(aref ,v 1))
(defmacro v-z (v) `(aref ,v 2))

;; Ops

(defun make-vector-s (s)
  (make-vector s s s))

(defmacro do-xyz ((&rest pairs) &body body-forms)
  `(do-vector-elements-known-size
	 ,+num-vector-dimensions+
	 ,pairs
	 ,@body-forms))

'(defmacro do-xyz ((&rest pairs) &body body-forms)
  "For each given symbol/vector pair, this binds the symbol to all 3
  components of the vector, while runnng the body-forms for each component."
  ;; First, generate a unique symbol to bind to each vector.
  ;; This is so we don't evaluate them more than once.
  (let ((vector-syms (loop for pair in pairs collect (gensym))))
	;; Output: We want to evaluate each vector form into the above symbols
	`(let (,@(loop for pair in pairs
				   for sym in vector-syms
				   collect `(,sym ,(second pair))))
	   ;; Output: Now, we want a symbol macrolet for each component, and also to run
	   ;; the body form.
	   ,@(loop for i from 0 to (1- +num-vector-dimensions+) collect
			   ;; For each sym/vector pair, macro-bind the sym to the vector's component.
			   ;; But remember to use the vector symbols bound above
			   `(symbol-macrolet
				  (,@(loop for pair in pairs
						   for sym in vector-syms
						   collect `(,(first pair) (aref ,sym ,i))))
				  ,@body-forms)))))

;; BRIEFLY TESTED
(defun dot-product (a b)
  (+ (* (v-x a) (v-x b))
	 (* (v-y a) (v-y b))
	 (* (v-z a) (v-z b))))

;; BRIEFLY TESTED
(defun cross-product (a b)
  (make-vector
	(- (* (v-y a) (v-z b))
	   (* (v-z a) (v-y b)))
	(- (* (v-z a) (v-x b))
	   (* (v-x a) (v-z b)))
	(- (* (v-x a) (v-y b))
	   (* (v-y a) (v-x b)))))
(defun ncross-product (a b)
  (setf (v-x a)	(- (* (v-y a) (v-z b))
				   (* (v-z a) (v-y b))))
  (setf (v-y a) (- (* (v-z a) (v-x b))
				   (* (v-x a) (v-z b))))
  (setf (v-z a)	(- (* (v-x a) (v-y b))
				   (* (v-y a) (v-x b))))
  a)


(defun ^2 (x) (* x x))
(defun neg (x) (* -1 x))

(defun magnitude (v)
  (sqrt (+ (^2 (v-x v))
		   (^2 (v-y v))
		   (^2 (v-z v)))))

(defun v+ (a b)
  (make-vector
	(+ (v-x a) (v-x b))
	(+ (v-y a) (v-y b))
	(+ (v-z a) (v-z b))))
(defun nv+ (a b)
	(setf (v-x a) (+ (v-x a) (v-x b)))
	(setf (v-y a) (+ (v-y a) (v-y b)))
	(setf (v-z a) (+ (v-z a) (v-z b)))
	a)

(defun v- (a b)
  (make-vector
	(- (v-x a) (v-x b))
	(- (v-y a) (v-y b))
	(- (v-z a) (v-z b))))
(defun nv- (a b)
	(setf (v-x a) (- (v-x a) (v-x b)))
	(setf (v-y a) (- (v-y a) (v-y b)))
	(setf (v-z a) (- (v-z a) (v-z b)))
	a)

(defun v* (v s)
  "Returns v scaled by s"
  (make-vector
	(* (v-x v) s)
	(* (v-y v) s)
	(* (v-z v) s)))
(defun nv* (v s)
  (setf (v-x v) (* (v-x v) s))
  (setf (v-y v) (* (v-y v) s))
  (setf (v-z v) (* (v-z v) s))
  v)

(defun vflip (v)
  (v* v -1))

(defun comp* (a b)
  (make-vector
	(* (v-x a) (v-x b))
	(* (v-y a) (v-y b))
	(* (v-z a) (v-z b))))
(defun ncomp* (a b)
  (setf (v-x a) (* (v-x a) (v-x b)))
  (setf (v-y a) (* (v-y a) (v-y b)))
  (setf (v-z a) (* (v-z a) (v-z b)))
  a)

(defun v/ (v s)
  "Returns v scaled by 1/s"
  ; (declare (number s))
  (v* v (/ 1 s)))
(defun nv/ (v s)
  "Returns v scaled by 1/s"
  ; (declare (number s))
  (nv* v (/ 1 s)))

(defun normalized (v)
  (v/ v (magnitude v)))
(defun normalize-f (v)
  "This actually modifies v, instead of just returning ||v||."
  ;; This can be re-written cleaner
  (let ((mag (magnitude v)))
	(setf (v-x v) (/ (v-x v) mag))
	(setf (v-y v) (/ (v-y v) mag))
	(setf (v-z v) (/ (v-z v) mag))
	v))
 
;; Helper functions

(defun dir-from (a b)
  "Returns a normalized direction vector from a to b."
  (let ((dir (v- b a)))
	(normalize-f dir)))

(defun distance (a b)
  (magnitude (v- a b)))

(defun cos-between (a b)
  (/ (dot-product a b)
	 (* (magnitude a)
		(magnitude b))))

(defconstant +rads-per-degs+ (/ pi 180))
(defconstant +degs-per-rads+ (/ 180 pi))
(defun degs->rads (d)
  (* d +rads-per-degs+))
(defun rads->degs (r)
  (* r +degs-per-rads+))

(defconstant +half-pi+ (/ pi 2))

(defun ~= (a b &optional (eps 1e-6))
  (and (< a (+ b eps))
	   (> a (- b eps))))

(defun angle-between (a b)
  "In radians"
  (acos (cos-between a b)))

(defun at-most-1 (x)
  (if (> x 1.0) 1.0
	x))
(defun angle-between-normals (n1 n2)
  "In radians"
  (acos (at-most-1
		  (dot-product n1 n2))))

;; Ray structure
;; TODO - try actually using (defstruct) for this.  Would that be faster for CMUCL?

(defun make-ray (origin dir)
  (vector origin dir))
(defun r-origin (ray)
  (aref ray 0))
(defun r-dir (ray)
  (aref ray 1))

(defun copy-ray (orig)
  (make-ray (copy-seq (r-origin orig))
	    (copy-seq (r-dir orig))))

;; Ray operations

(defun point-on-ray (ray t-val)
  ; (declare (number t-val))
  (v+ (r-origin ray)
	  (v* (r-dir ray) t-val)))

(defun make-ray-from-line (a b)
  (make-ray
	a	; From the first point..
	(normalized (v- b a))))	; Use the normalized a->b vector as the direction

;; Geometry

;; spheres

(defun ray-sphere-intersection-t-vals (ray sphere-origin sphere-radius)
  ; (declare (vector sphere-origin))
  ; (declare (number sphere-radius))
  "Returns t such that r(t) is a point on the sphere.  t may be negative!  If there is no intersection, it returns nil."
  ;; TODO - add declares to these let's
  (let* ((rd (r-dir ray))
		 (ro (r-origin ray))
		 (sc sphere-origin)
		 (Xd (v-x rd)) (Yd (v-y rd)) (Zd (v-z rd))
		 (Xo (v-x ro)) (Yo (v-y ro)) (Zo (v-z ro))
		 (Xc (v-x sc)) (Yc (v-y sc)) (Zc (v-z sc))
		 (B (* 2 (+ (* Xd (- Xo Xc))
					(* Yd (- Yo Yc))
					(* Zd (- Zo Zc)))))
		 (C (+ (^2 (- Xo Xc))
			   (^2 (- Yo Yc))
			   (^2 (- Zo Zc))
			   (neg (^2 sphere-radius))))
		 ;; The discriminant
		 (disc (- (^2 B) (* 4 C))))
	; (declare (number Xd Yd Zd
					 ; Xo Yo Zo
					 ; Xc Yc Zc
					 ; B C
					 ; disc))
	; (declare (vector rd ro sc))

	(cond ((< disc 0.0)
		   ;; No intersection
		   nil)
		  (t
			;; Calculate intersection - two roots
			(let* ((sqrt-disc (sqrt disc))
				   (ta (- (neg B) sqrt-disc))
				   (tb (+ (neg B) sqrt-disc)))
			  ; (declare (number num0 num1))
			  ;; If ta is non-negative, return it (it's always smaller than tb)
			  ;; Of course, return it halved.. we delayed the /2a part of the eqn..
			  ;(if (> ta tb) (break))
			  ;(dbl ta tb)
			  (if (= ta tb) nil	;; Consider tangential hits no hit
				(if (>= ta 0.0)
				  ;; TA is non-neg, so both must be non-neg.  Return both halved
				  (list (* 0.5 ta) (* 0.5 tb))
				  ;; Well, is tb non-neg?  If so, just return that
				  (if (>= tb 0.0)
					(list (* 0.5 tb))
					;; Both are negative!  No hits.
					'())))
			  )))))

(defun sphere-normal-at (center radius pt)
  ; (declare (number radius))
  (normalized
	(make-vector
	  (/ (- (v-x pt) (v-x center)) radius)
	  (/ (- (v-y pt) (v-y center)) radius)
	  (/ (- (v-z pt) (v-z center)) radius))))

;;;;;;;;;;;;;;;;;;;;
;; TEST
;;;;;;;;;;;;;;;;;;;;

'(defun TEST ()
   (let ((x (make-vector (random 10) (random 10) (random 10)))
		 (y (make-vector (random 10) (random 10) (random 10)))
		 (z (make-vector (random 10) (random 10) (random 10))))
	 (dbl x y (cross-product x y))
	 (dbl (dot-product x (cross-product x y)))
	 (dbl (dot-product y (cross-product x y)))
	 (let ((c (cross-product x y)))
	   (dbl c (/ (dot-product c (normalized c)) (magnitude c))))
	 (let ((ray (make-ray-from-line x y))
		   (point)
		   (o-p))
	   (setf point (point-on-ray ray 2.0))
	   (dbl (magnitude (v- point (r-origin ray))))
	   (setf o-p (v- point (r-origin ray)))
	   (dbl (/ (dot-product o-p (v- y x))
			   (* (magnitude o-p) (magnitude (v- y x)))))
	   )
	 ))

'(defun TEST-sphere ()
   (blk "sphere test")
   (let ((origin (make-vector 0 0 0))
		 (sphere-center (make-vector -1 -1 0))
		 (start (make-vector 1 1 0))
		 sphere)
	 (setf sphere (make-sphere sphere-center 1))
	 (let ((ray (make-ray-from-line start origin))
		   (intx))
	   (setf intx (ray-sphere-intersection ray sphere))
	   (dbl intx (sphere-normal-at sphere intx)))))

'(TEST-sphere)

steven/clos.lisp

deleted100644 → 0
+0 −53
Original line number Diff line number Diff line
(in-package :an.steven.clos)

(defmacro defclass-java-style (name base-classes &rest field-forms)
  (let ((field-decls '()))
	;; Build the field decls
	(dolist (field-form field-forms)
		(push
		  ;; field-decl-java-style expects expanded args, like (fdjs kind name etc. etc.)
		  ;; So we gotta use apply
		  (apply #'field-decl-java-style field-form)
		  field-decls))
	;; Now build the whole defclass
	`(defclass ,name ,base-classes ,field-decls)))

(defun field-decl-java-style (kind name initarg initform &rest other)
  "Only meant for use by defclass-java-style!  This won't work inside a normal defclass!"
  `(,name :initarg ,initarg
		  :initform ,initform
		  ;; Define an accessor/reader with the same name
		  ,(switch kind
				   ((:public :accessor)
					(:readonly :reader))
				   (error "incorrect field kind!  Should be :public or :readonly"))
		  ,name
		  ,@other))


;; EXAMPLES
'(defclass-java-style vehicle ())
'(defclass-java-style boat (vehicle)
					  (:public engine :engine nil)
					  (:public length :length 100)
					  (:readonly is-on :is-on nil))

;; More helpers

(defmacro define-typical-print-method (class-name (object stream) &body body)
  `(defmethod print-object ((,object ,class-name) ,stream)
    (print-unreadable-object (,object ,stream :type t :identity t)
      ,@body)))

(defmacro define-formatting-print-method (class-name object fmt-string &rest fmt-args)
  `(define-typical-print-method ,class-name (,object strm)
    (format strm ,fmt-string ,@fmt-args)))

;; EXAMPLES
'(define-typical-print-method primitive-closed-convex-model (obj strm)
  (format strm "primitive: ~a" (primitive obj)))

'(define-formatting-print-method
    primitive-closed-convex-model obj
  "primitive: ~a" (primitive obj))
    

steven/debug.lisp

deleted100644 → 0
+0 −174
Original line number Diff line number Diff line
(in-package :an.steven.debug)

(defvar *debug-output* *trace-output*)	; true will just send it to std-out

;;; Printing and logging

(defmacro newline () `(format *debug-output* "~%"))
(defalias br newline)
(defmacro hr () `(format *debug-output* "~%----------------~%"))
(defmacro block-format (format-string &rest args)
  `(progn 
	 (hr)
	 (format *debug-output* ,format-string ,@args)
	 (hr)))
(defalias blk block-format)

;;; Convenient printing tricks

(export 'show-form-and-value-l)
(defmacro show-form-and-value-l (form)
  (let ((value-var (gensym)))
	`(let ((,value-var ,form))
	   (format *debug-output* "~a -> ~a~%"  ',form ,form)
	   ,value-var)))
(defalias dbv show-form-and-value-l)
(defmacro show-form-and-value (form)
  `(format *debug-output* "~a -> ~a" ',form ,form) )
(defmacro show-value (form)
  `(format *debug-output* "~a" ,form) )
(defmacro show-self-evaluating (form)
  ;; TODO - this one should take form, get its evaluation, then build a string out of it - instead of using ~a
  `(format *debug-output* "~a" ,form) )
(defmacro show-self-evaluating-l (form)
  ;; TODO - this one should take form, get its evaluation, then build a string out of it - instead of using ~a
  `(format *debug-output* "~a~%" ,form) )
(defmacro show-form-smartly (form)
  "If form is self-evaluating, it just shows the value.  Otherwise, it shows the form and the value."
  (cond ((self-evaluating-p form)
		 `(show-self-evaluating ,form))
		(t
		  `(show-form-and-value ,form) )))

(defmacro show-form-smartly-l (form)
  "If form is self-evaluating, it just shows the value.  Otherwise, it shows the form and the value."
  (cond ((self-evaluating-p form)
		 `(show-self-evaluating-l ,form))
		(t
		  `(show-form-and-value-l ,form) )))

(defmacro debug-sentence (&rest parts)
  "
  <<<<
  Print a list of forms in a smart manner: If it's self-evaluating (like a string or number), just print it directly.  If it's a form (like (+ 1 2)), print the form and evaluation (so it would become (+ 1 2) = 3).
  >>>>
  "
  (let ((out (list)))
	(dolist (part (reverse parts))
	  (push `(format t "; ") out)
	  (push `(show-form-smartly ,part) out)
	)
	(push 'progn out)
	out ))
(defalias dbmsg debug-sentence)
(defmacro dbl (&rest parts)
  "
  <<<<
  Print a line to *debug-output*.
  Ex: (dbl \"Let's do some math..\" (+ 1 2) (* 2 3) (sqrt 2))
  This would yield: Let's do some math.. (+ 1 2) = 3 (* 2 3) = 6 (sqrt 2) = 1.4..
  So it's useful for debugging and tracing variables.
  >>>>
  "
  `(progn
	 (dbmsg ,@parts)
	 (format t "~%")
	 ))

(defmacro show-smartly-and-return (form)
  `(let ((result ,form))
	 (format *debug-output* "~a -> ~a~%" ',form result)
	 result))

(defmacro debug-progn (&rest forms)
  (let ((out '()))
	;; Evaluate and return the last form
	(push `(show-smartly-and-return ,(car (last forms)))
		  out)
	(dolist (form (reverse (butlast forms)))
	  (push `(show-form-smartly-l ,form) out))
	(push 'progn out)))
(defalias dbp debug-progn)

(defmacro monitor-progn (mtr-vars &rest forms)
  (let ((out '()))
	;; Evaluate and return the last form
	(push `(show-smartly-and-return ,(car (last forms)))
		  out)
	(dolist (form (reverse (butlast forms)))
	  (push `(dbl ,@mtr-vars)
			out)
	  (push `(format *debug-output* "    monitor: ")
			out)
	  (push `(show-form-smartly-l ,form) out))
	(push 'progn out)))

(defmacro dbl-if (cond-exp &rest forms)
  `(when ,cond-exp (dbl ,@forms)))

;; Value assertions
(defvar *assert-value-enabled* t)
(defmacro assert-value (value-form value-sym assert-form)
  "This will evaluate value-form once and bind value-sym to the resulting value.
  Then, it evaluates assert-form - if that returns t, then value-sym's value will be returned.
  If it assert-form evaluates to nil, a detailed error will be signaled."
  (cond (*assert-value-enabled*
		  `(let ((,value-sym ,value-form))
			 (when (nil? ,assert-form)
			   (dbl "*** assert-value failed!  value-form" ',value-form "evaluated to" ,value-sym "assert-form" ',assert-form)
			   (error "Assertion failed!  See above"))
			 ,value-sym))
		;; Asserts are disabled
		;; Just return the value-form
		(t value-form)))

(defmacro with-trace ((&rest funcs) &body body)
  "Evaluates to the given body as usual, but traces the given functions.  Then, it untraces then after the body is finished evaluating.  NOTE: If a given function name was already being traced, it WILL be untraced outside of this form.  This is somewhat undesirable..and it may be changed in the future."
  (let ((body-result-sym (gensym)))
    `(progn
      (trace ,@funcs)
      (let ((,body-result-sym (progn ,@body)))
	(untrace ,@funcs)
	,body-result-sym))))

;; Test code
(defun TEST-with-trace ()
  (progn
    (defun foo (x) 'foo)
    (defun bar (x) 'bar)
    (with-trace (foo bar)
      (foo 1) (bar 2))))

;;; Testings

(defun TEST-debug ()
  (block-format "begin testing")

  (show-form-and-value (+ 1 2))
  (br)
  (show-form-and-value 69)
  (br)
  (show-form-smartly 69)
  (br)
  (show-form-smartly (+ 1 2))
  (br)

  (dbl "end of tests" (+ 1 2 3) "we're done!")

  (dbl (defvar x 1))
  (dbl (debug-progn (incf x) (incf x) (incf x)))
  (dbl (progn (decf x) (decf x)))

  (blk "testing monitor progn")
  (defvar y 2)
  (monitor-progn (x y)
				 (decf x)
				 (incf y)
				 (incf x)
				 (incf y)
				 (incf x)
				 (decf x))

  (blk "done")
  (let ((seven 7))
	(dbl "ok done for real now" seven) ))
Loading