Browse code
initial
fiddlerwoaroof authored on 02/05/2016 21:50:01Showing 5 changed files
| 1 | 1 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,14 @@ |
| 1 |
+;;;; 3dr.asd |
|
| 2 |
+ |
|
| 3 |
+(asdf:defsystem #:3dr |
|
| 4 |
+ :description "Describe 3dr here" |
|
| 5 |
+ :author "Your Name <your.name@example.com>" |
|
| 6 |
+ :license "Specify license here" |
|
| 7 |
+ :depends-on (#:fwoar.lisputils |
|
| 8 |
+ #:alexandria |
|
| 9 |
+ #:serapeum |
|
| 10 |
+ #:lparallel) |
|
| 11 |
+ :serial t |
|
| 12 |
+ :components ((:file "package") |
|
| 13 |
+ (:file "3dr"))) |
|
| 14 |
+ |
| 0 | 15 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,196 @@ |
| 1 |
+;;;; 3dr.lisp |
|
| 2 |
+ |
|
| 3 |
+(in-package #:3dr) |
|
| 4 |
+ |
|
| 5 |
+;;; "3dr" goes here. Hacks and glory await! |
|
| 6 |
+ |
|
| 7 |
+(defstruct (point (:type vector)) x y z) |
|
| 8 |
+ |
|
| 9 |
+(defclass plane () |
|
| 10 |
+ ((cells :initarg :cells :accessor cells :type (array integer (* *))) |
|
| 11 |
+ (distance :initarg :distance :accessor distance :type integer))) |
|
| 12 |
+ |
|
| 13 |
+;(declaim (ftype (function ((vector integer 3) integer) (vector rational 3)) intercept-coordinate)) |
|
| 14 |
+(defun intercept-coordinate (point distance &optional out-point) |
|
| 15 |
+ ;(declare (inline) (optimize (speed 3))) |
|
| 16 |
+ (when (null out-point) |
|
| 17 |
+ ;(break) |
|
| 18 |
+ (setf out-point (vector 0 0 0))) |
|
| 19 |
+ (let ((a (elt point 0)) (b (elt point 1)) (c (elt point 2))) |
|
| 20 |
+ (setf (elt out-point 0) distance) |
|
| 21 |
+ (setf (elt out-point 1) (/ (* b distance) a)) |
|
| 22 |
+ (setf (elt out-point 2) (/ (* c distance) a)) |
|
| 23 |
+ out-point)) |
|
| 24 |
+ |
|
| 25 |
+(defun run-plane (plane point-cb) |
|
| 26 |
+ ;(declare (optimize (speed 3))) |
|
| 27 |
+ (let ((a (distance plane)) |
|
| 28 |
+ (points (cells plane))) |
|
| 29 |
+ (destructuring-bind (b-bound c-bound) (array-dimensions points) |
|
| 30 |
+ (lparallel:pdotimes (b (1- b-bound)) |
|
| 31 |
+ (let ((the-point (make-point :x a :y (- b (/ b-bound 2)) :z 0)) |
|
| 32 |
+ (out-point (make-point :x 0 :y 0 :z 0))) |
|
| 33 |
+ (dotimes (c (1- c-bound)) |
|
| 34 |
+ (setf (point-z the-point) (- c (/ c-bound 2))) |
|
| 35 |
+ (setf (aref points b c) |
|
| 36 |
+ (funcall point-cb the-point out-point)))))))) |
|
| 37 |
+ |
|
| 38 |
+(declaim (ftype (function ((vector rational 3) (vector rational 3)) float) c-distance)) |
|
| 39 |
+(defun c-distance (point-1 point-2) |
|
| 40 |
+ ;(declare (optimize (speed 0) (safety 3) (debug 3))) |
|
| 41 |
+ (when (not (and (point-x point-1) (point-x point-2))) |
|
| 42 |
+ (break)) |
|
| 43 |
+ |
|
| 44 |
+ ;(declare (inline) (optimize (speed 3) (safety 1) (debug 0) (space 0))) |
|
| 45 |
+ (sqrt (+ (expt (- (aref point-2 0) (aref point-1 0)) 2) |
|
| 46 |
+ (expt (- (aref point-2 1) (aref point-1 1)) 2) |
|
| 47 |
+ (expt (- (aref point-2 2) (aref point-1 2)) 2)))) |
|
| 48 |
+ |
|
| 49 |
+(defun extract-projected-point (point obj-dist &optional out-point) |
|
| 50 |
+ ;(declare (inline) (optimize (speed 3))) |
|
| 51 |
+ (intercept-coordinate point obj-dist out-point)) |
|
| 52 |
+ |
|
| 53 |
+(defclass shape () |
|
| 54 |
+ ((origin :initarg :origin :accessor origin) |
|
| 55 |
+ (radius :initarg :radius :accessor radius) |
|
| 56 |
+ (args :initarg :args :accessor args) |
|
| 57 |
+ (render-func :initarg :render-func :accessor render-func))) |
|
| 58 |
+ |
|
| 59 |
+(defgeneric get-render-cb (shape)) |
|
| 60 |
+(defmethod get-render-cb ((shape shape)) |
|
| 61 |
+ (with-slots (origin radius render-func args) shape |
|
| 62 |
+ (apply render-func origin radius args))) |
|
| 63 |
+ |
|
| 64 |
+(defun make-neg-sphere-cb (origin radius) |
|
| 65 |
+ (let ((obj-dist (point-x origin)) |
|
| 66 |
+ (r_sqr (expt radius 2))) |
|
| 67 |
+ (lambda (point &optional out-point extracted-point) |
|
| 68 |
+ ;(declare (inline) (optimize (speed 3))) |
|
| 69 |
+ (let* ((point (or extracted-point (extract-projected-point point obj-dist out-point))) |
|
| 70 |
+ (d_o (c-distance origin point))) |
|
| 71 |
+ (if (<= d_o radius) |
|
| 72 |
+ (* -1 (ceiling (sqrt (- r_sqr (expt d_o 2))))) |
|
| 73 |
+ 0))))) |
|
| 74 |
+ |
|
| 75 |
+;; d_o + r : upright :: upright : r - d_o |
|
| 76 |
+;; upright^2 = r^2 - d_o^2 |
|
| 77 |
+;; upright = sqrt ( r^2 - d_o^2 ) |
|
| 78 |
+(defun make-sphere-cb (origin radius) |
|
| 79 |
+ (let ((obj-dist (point-x origin)) |
|
| 80 |
+ (r_sqr (expt radius 2))) |
|
| 81 |
+ (lambda (point &optional out-point extracted-point) |
|
| 82 |
+ ;(declare (inline) (optimize (speed 3))) |
|
| 83 |
+ (let* ((out-point (or out-point (make-point :x 0 :y 0 :z 0))) |
|
| 84 |
+ (point (or extracted-point (extract-projected-point point obj-dist out-point)))) |
|
| 85 |
+ (let ((d_o (c-distance origin point))) |
|
| 86 |
+ (values (if (<= d_o radius) |
|
| 87 |
+ (ceiling (* (/ (sqrt (- r_sqr |
|
| 88 |
+ (expt d_o |
|
| 89 |
+ 2))) |
|
| 90 |
+ radius) |
|
| 91 |
+ #. (expt 2 7))) |
|
| 92 |
+ 0) |
|
| 93 |
+ point)))))) |
|
| 94 |
+ |
|
| 95 |
+(defun make-donut-cb (origin radius width) |
|
| 96 |
+ (let ((pos-cb (make-sphere-cb origin radius)) |
|
| 97 |
+ (neg-cb (make-neg-sphere-cb origin (- radius width))) |
|
| 98 |
+ (obj-dist (point-x origin))) |
|
| 99 |
+ (lambda (point &optional out-point) |
|
| 100 |
+ ;(declare (inline) (optimize (speed 3))) |
|
| 101 |
+ (let* ((out-point (or out-point (make-point :x 0 :y 0 :z 0))) |
|
| 102 |
+ (extracted-point (extract-projected-point point obj-dist out-point))) |
|
| 103 |
+ (+ (funcall pos-cb point out-point extracted-point) |
|
| 104 |
+ (funcall neg-cb point out-point extracted-point)))))) |
|
| 105 |
+ |
|
| 106 |
+(defun combine-cbs (&rest cbs) |
|
| 107 |
+ (lambda (point &optional out-point) |
|
| 108 |
+ (let ((out-point (or out-point (make-point :x 0 :y 0 :z 0)))) |
|
| 109 |
+ (loop for cb in cbs sum (funcall cb point out-point))))) |
|
| 110 |
+ |
|
| 111 |
+(defun combine-shapes (&rest shapes) |
|
| 112 |
+ (let* ((shape-cbs (mapcar #'get-render-cb |
|
| 113 |
+ (lparallel:psort shapes #'< |
|
| 114 |
+ :key (lambda (shape) |
|
| 115 |
+ (with-slots (origin radius) shape |
|
| 116 |
+ (- |
|
| 117 |
+ (c-distance #(0 0 0) |
|
| 118 |
+ origin) |
|
| 119 |
+ radius)))))) |
|
| 120 |
+ (origins (mapcar 'origin shapes)) |
|
| 121 |
+ (radii (mapcar 'radius shapes)) |
|
| 122 |
+ (light-scaling-factor (lparallel:pmapcar |
|
| 123 |
+ (lambda (origin radius) |
|
| 124 |
+ (abs |
|
| 125 |
+ (/ (- (c-distance #(0 100 100) |
|
| 126 |
+ origin) |
|
| 127 |
+ radius) |
|
| 128 |
+ 100))) |
|
| 129 |
+ origins |
|
| 130 |
+ radii))) |
|
| 131 |
+ (lambda (point &optional out-point) |
|
| 132 |
+ (let ((out-point (or out-point (make-point :x 0 :y 0 :z 0)))) |
|
| 133 |
+ (loop for shape-cb in shape-cbs |
|
| 134 |
+ for scale-factor in light-scaling-factor |
|
| 135 |
+ for val = (ceiling |
|
| 136 |
+ (* scale-factor |
|
| 137 |
+ (funcall shape-cb point out-point))) |
|
| 138 |
+ until (< 0 val) |
|
| 139 |
+ finally (return val)))))) |
|
| 140 |
+ |
|
| 141 |
+(defun array-to-pgm (arr) |
|
| 142 |
+ ;(declare (optimize (speed 3))) |
|
| 143 |
+ (with-output-to-string (s) |
|
| 144 |
+ (destructuring-bind (height width) (array-dimensions arr) |
|
| 145 |
+ (format s "P2~%~3d ~3d~%~d~%" |
|
| 146 |
+ width height |
|
| 147 |
+ (1+ (reduce #'max (make-array (* width height) :displaced-to arr))))) |
|
| 148 |
+ (loop with (x-bound y-bound) = (array-dimensions arr) |
|
| 149 |
+ for x from 0 to (1- x-bound) |
|
| 150 |
+ do (loop for y from 0 to (1- y-bound) |
|
| 151 |
+ for val = (aref arr x y) |
|
| 152 |
+ do (princ val s) |
|
| 153 |
+ do (princ #\space s)) |
|
| 154 |
+ do (terpri s)))) |
|
| 155 |
+ |
|
| 156 |
+(defmacro defshape (render-func origin radius &rest args) |
|
| 157 |
+ `(make-instance 'shape |
|
| 158 |
+ :render-func (function ,render-func) |
|
| 159 |
+ :origin (copy-seq ,origin) |
|
| 160 |
+ :radius ,radius |
|
| 161 |
+ :args (list ,@args))) |
|
| 162 |
+ |
|
| 163 |
+(defun main (&rest args) |
|
| 164 |
+ (declare (ignore args)) |
|
| 165 |
+ ;(sb-profile:profile intercept-coordinate c-distance) |
|
| 166 |
+ (let ((the-plane (make-instance 'plane |
|
| 167 |
+ :cells (make-array '(2048 2048)) |
|
| 168 |
+ :distance 50)) |
|
| 169 |
+ (lparallel:*kernel* (lparallel:make-kernel 32)) |
|
| 170 |
+ (sphere (make-instance 'shape))) |
|
| 171 |
+ |
|
| 172 |
+ (labels ((100- (x) (- x 100)) |
|
| 173 |
+ (random-coord () (100- (random 200)))) |
|
| 174 |
+ (time |
|
| 175 |
+ (run-plane the-plane |
|
| 176 |
+ (apply #'combine-shapes |
|
| 177 |
+ (loop for _ from 0 to 100 |
|
| 178 |
+ collect (defshape make-sphere-cb |
|
| 179 |
+ (vector (1+ (random 50)) (random-coord) (random-coord)) |
|
| 180 |
+ (+ 3 (random 30)))))))) |
|
| 181 |
+ |
|
| 182 |
+ (with-open-file (s "/tmp/spheres.pgm" :direction :output :if-exists :supersede) |
|
| 183 |
+ (write-sequence (array-to-pgm (cells the-plane)) |
|
| 184 |
+ s)) |
|
| 185 |
+ nil) |
|
| 186 |
+ ;(sb-profile:report) |
|
| 187 |
+ ) |
|
| 188 |
+ |
|
| 189 |
+;(loop with (x-bound y-bound) = (array-dimensions (cells the-plane)) |
|
| 190 |
+; for x from 0 to (1- x-bound) |
|
| 191 |
+; do (loop for y from 0 to (1- y-bound) |
|
| 192 |
+; for val = (aref (cells the-plane) x y) |
|
| 193 |
+; when (= val 0) do (princ #\space) |
|
| 194 |
+; unless (= val 0) do (princ val) |
|
| 195 |
+; do (princ #\space)) |
|
| 196 |
+; do (terpri)) |
| 0 | 2 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,35 @@ |
| 1 |
+(in-package #:3dr.octcone) |
|
| 2 |
+ |
|
| 3 |
+(defun make-adj-arr (&optional (size 25)) |
|
| 4 |
+ (make-array size :adjustable t :fill-pointer 0)) |
|
| 5 |
+ |
|
| 6 |
+(defstruct (bounds (:type vector)) |
|
| 7 |
+ tl tr bl br) |
|
| 8 |
+ |
|
| 9 |
+(defclass octcone () |
|
| 10 |
+ ((nw-bucket :initarg :nw-bucket :accessor nw-bucket :initform (make-adj-arr)) |
|
| 11 |
+ (ne-bucket :initarg :ne-bucket :accessor ne-bucket :initform (make-adj-arr)) |
|
| 12 |
+ (sw-bucket :initarg :sw-bucket :accessor sw-bucket :initform (make-adj-arr)) |
|
| 13 |
+ (se-bucket :initarg :se-bucket :accessor se-bucket :initform (make-adj-arr)) |
|
| 14 |
+ (overflow-bucket :initarg :overflow-bucket :accessor overflow-bucket :initform (make-adj-arr)) |
|
| 15 |
+ (center :initarg :center :accessor center))) |
|
| 16 |
+ |
|
| 17 |
+(defun bucket-point (point octcone) |
|
| 18 |
+ (with-slots (nw-bucket ne-bucket sw-bucket se-bucket center) octcone |
|
| 19 |
+ (with-accessors ((center-y 3dr::point-y) (center-z 3dr::point-z)) center |
|
| 20 |
+ (with-accessors ((point-y 3dr::point-y) (point-z 3dr::point-z)) point |
|
| 21 |
+ (vector-push-extend |
|
| 22 |
+ point |
|
| 23 |
+ (if (< point-y center-y) |
|
| 24 |
+ (if (< point-z center-z) sw-bucket nw-bucket) |
|
| 25 |
+ (if (< point-z center-z) se-bucket ne-bucket))))))) |
|
| 26 |
+ |
|
| 27 |
+(defparameter *octc* (make-instance 'octcone :center (vector 0 0 0))) |
|
| 28 |
+ |
|
| 29 |
+(flet ((10- (x) (- 10 x))) |
|
| 30 |
+ (defparameter *points* (loop repeat 100 |
|
| 31 |
+ collect (vector (10- (random 20)) (10- (random 20)) (10- (random 20)))))) |
|
| 32 |
+ |
|
| 33 |
+(mapcar (lambda (x) |
|
| 34 |
+ (bucket-point x *octc*)) |
|
| 35 |
+ *points*) |