Data commit

Task/Draw-a-sphere/Emacs-Lisp/draw-a-sphere.l

@@ -0,0 +1,54 @@
+; Draw a sphere
+
+(defun normalize (v)
+  "Normalize a vector."
+  (setq invlen (/ 1.0 (sqrt (dot v v))))
+  (mapcar (lambda (x) (* invlen x)) v))
+
+(defun dot (v1 v2)
+  "Dot product of two vectors."
+  (+ (* (car v1) (car v2))
+     (* (cadr v1) (cadr v2))
+     (* (caddr v1) (caddr v2))))
+
+(defun make-array (size)
+  "Create an empty array with size*size elements."
+  (setq m-array (make-vector size nil))
+  (dotimes (i size)
+    (setf (aref m-array i) (make-vector size 0)))
+  m-array)
+
+(defun pic-lines (arr size)
+  "Turn array into a string."
+  (setq all "")
+  (dotimes (y size)
+    (setq line "")
+    (dotimes (x size)
+      (setq line (concat line (format "%i \n" (elt (elt arr y) x)))))
+    (setq all (concat all line "\n")))
+  all)
+
+(defun pic-show (arr size)
+  "Convert size*size array to grayscale PBM image and show it."
+  (insert-image (create-image (concat (format "P2
+%i %i 255\n" size size) (pic-lines arr size)) 'pbm t)))
+
+(defun sphere (size k amb dir)
+  "Draw a sphere."
+  (let ((arr (make-array size))
+        (ndir (normalize dir))
+        (r (/ size 2)))
+    (dotimes (yp size)
+      (dotimes (xp size)
+        (setq x (- xp r))
+        (setq y (- yp r))
+        (setq z (- (* r r) (* x x) (* y y)))
+        (if (>= z 0)
+          (let* ((vec (normalize (list x y (sqrt z))))
+                 (s (max 0 (dot vec ndir)))
+                 (lum (max 0 (min 255 (* 255 (+ amb (expt s k))
+                                                    (/ (1+ amb)))))))
+            (setf (elt (elt arr yp) xp) lum)))))
+    (pic-show arr size)))
+
+(sphere 200 1.5 0.2 '(-30 -30 50))