src/3d/demo.lisp @ d9b504caca3b

(in-package #:coding-math.3d.demo)


;;;; Config
(setf *bypass-cache* t)
(defparameter *width* 600)
(defparameter *height* 400)

(defparameter *center-x* (/ *width* 2))
(defparameter *center-y* (/ *height* 2))


;;;; Utils
(defmacro with-centered-coords (&body body)
  `(in-context
     (translate *center-x* *center-y*)
     ,@body))

(defmacro with-setup (&body body)
  `(with-fps
    (background (gray 1))
    (with-centered-coords
      ,@body)))


;;;; Draw
(defun draw-point (screen size)
  (circle (vec-x screen) (vec-y screen) size))

;;;; Structs
(defstruct (point (:constructor make-point (world &optional screen)))
  world screen)


;;;; Sketch
(defun project (points focal-length)
  (map nil
       (lambda (p)
         (with-vecs ((screen (point-screen p))
                     (world (point-world p)))
           (let ((scale (/ focal-length (+ focal-length world.z))))
             (setf screen.x (* scale world.x)
                   screen.y (* scale world.y)))))
       points))

(defun translate-model (points x y z)
  (map nil (lambda (p)
             (with-vec (p (point-world p))
               (incf p.x x)
               (incf p.y y)
               (incf p.z z)))
       points))

(defsketch demo
    ((width *width*) (height *height*) (y-axis :down) (title "Coding Math")
     (mouse (cons 0 0))
     ;; variables
     (fl 300.0)
     (r 200.0)
     (points
       (make-array 8
         :initial-contents
         (list
           (make-point (vec (- r) (- r) 1000.0) (zero-vec))
           (make-point (vec     r (- r) 1000.0) (zero-vec))
           (make-point (vec     r (- r)  500.0) (zero-vec))
           (make-point (vec (- r) (- r)  500.0) (zero-vec))
           (make-point (vec (- r)     r 1000.0) (zero-vec))
           (make-point (vec     r     r 1000.0) (zero-vec))
           (make-point (vec     r     r  500.0) (zero-vec))
           (make-point (vec (- r)     r  500.0) (zero-vec)))))
     (dirty t)
     ;; pens
     (simple-pen (make-pen :fill (gray 0.1)))
     (line-pen (make-pen :stroke (gray 0.1) :weight 1))
     )
  (with-setup
    (flet
        ((draw-line (&rest vertices)
           (loop :for (a b) ; lame way to close the loop...
                 :in (n-grams 2 (append vertices (list (car vertices))))
                 :do (with-vecs ((a (point-screen (aref points a)))
                                 (b (point-screen (aref points b))))
                       (line a.x a.y b.x b.y)))))
      (when dirty
        (setf dirty nil)
        (project points fl))
      (with-pen simple-pen
        ; (loop :for p :across points
        ;       :do (draw-point (point-screen p) 5))
        nil)
      (with-pen line-pen
        (draw-line 0 1 2 3)
        (draw-line 0 3 7 4)
        (draw-line 1 2 6 5)
        (draw-line 6 5 4 7)
        nil
        ))
    ;;
    ))


;;;; Mouse
(defun mousemove (instance x y)
  (with-slots (mouse) instance
    (setf (car mouse) x)
    (setf (cdr mouse) y)
    ;;
    ;;
    )
  )

(defun mousedown-left (instance x y)
  (declare (ignorable instance x y))
  )

(defun mousedown-right (instance x y)
  (declare (ignorable instance x y))
  )

(defun mouseup-left (instance x y)
  (declare (ignorable instance x y))
  )

(defun mouseup-right (instance x y)
  (declare (ignorable instance x y))
  )


(defmethod kit.sdl2:mousemotion-event ((window demo) ts b x y xrel yrel)
  (declare (ignore ts b xrel yrel))
  (mousemove window x y))

(defmethod kit.sdl2:mousebutton-event ((window demo) state ts button x y)
  (declare (ignore ts))
  (funcall (case state
             (:mousebuttondown
              (case button
                (1 #'mousedown-left)
                (3 #'mousedown-right)))
             (:mousebuttonup
              (case button
                (1 #'mouseup-left)
                (3 #'mouseup-right))))
           window x y))


;;;; Keyboard
(defun keydown (instance scancode)
  (declare (ignorable instance))
  (setf (slot-value instance 'dirty) t)
  (scancode-case scancode
    (:scancode-space (sketch::prepare instance))
    ;;
    (:scancode-left  (translate-model (slot-value instance 'points) -15 0 0))
    (:scancode-right (translate-model (slot-value instance 'points) 15 0 0))
    (:scancode-up    (translate-model (slot-value instance 'points) 0 -15 0))
    (:scancode-down  (translate-model (slot-value instance 'points) 0 15 0))
    (:scancode-s    (translate-model (slot-value instance 'points) 0 0 -15))
    (:scancode-w  (translate-model (slot-value instance 'points) 0 0 15))
    ;;
    ))

(defun keyup (instance scancode)
  (declare (ignorable instance))
  (scancode-case scancode
    (:scancode-space
     nil)))


(defmethod kit.sdl2:keyboard-event ((instance demo) state timestamp repeatp keysym)
  (declare (ignore timestamp repeatp))
  (cond
    ((eql state :keyup) (keyup instance (sdl2:scancode-value keysym)))
    ((eql state :keydown) (keydown instance (sdl2:scancode-value keysym)))
    (t nil)))


;;;; Run
; (defparameter *demo* (make-instance 'demo))