88 lines
2.8 KiB
Common Lisp
88 lines
2.8 KiB
Common Lisp
(defstruct line points)
|
|
(defstruct circle radius centre)
|
|
(defstruct polygon points)
|
|
|
|
(defun line (start-x start-y end-x end-y)
|
|
(list (make-line :points (vector start-x start-y end-x end-y))))
|
|
|
|
(defun circle (radius centre-x centre-y)
|
|
(list (make-circle :radius radius :centre (vector centre-x centre-y))))
|
|
|
|
(defun rectangle (left-x bottom-y width height)
|
|
(let ((right-x (+ left-x width))
|
|
(top-y (+ bottom-y height)))
|
|
(list (make-polygon
|
|
:points (vector left-x bottom-y
|
|
left-x top-y
|
|
right-x top-y
|
|
right-x bottom-y)))))
|
|
|
|
(defun centre-rectangle (centre-x centre-y width height)
|
|
(let ((left-x (- centre-x (/ width 2)))
|
|
(bottom-y (- centre-y (/ height 2))))
|
|
(rectangle left-x bottom-y width height)))
|
|
|
|
(defun translate (delta-x delta-y drawing)
|
|
(defun translate-points (points)
|
|
(let ((new-points (copy-seq points)))
|
|
(do ((i 0 (+ i 2)))
|
|
((>= i (length points)))
|
|
(incf (aref new-points i) delta-x)
|
|
(incf (aref new-points (1+ i)) delta-y))
|
|
new-points))
|
|
(defun translate-primitive (primitive)
|
|
(typecase primitive
|
|
(line (make-line :points (translate-points (line-points primitive))))
|
|
(circle
|
|
(make-circle
|
|
:radius (circle-radius primitive)
|
|
:centre (translate-points (circle-centre primitive))))
|
|
(polygon
|
|
(make-polygon
|
|
:points (translate-points (polygon-points primitive))))))
|
|
(mapcar #'translate-primitive drawing))
|
|
|
|
(defun scale (scale-factor drawing)
|
|
(defun scale-points (points)
|
|
(let ((new-points (copy-seq points)))
|
|
(dotimes (i (length points))
|
|
(setf (aref new-points i)
|
|
(* scale-factor (aref new-points i))))
|
|
new-points))
|
|
(defun scale-primitive (primitive)
|
|
(typecase primitive
|
|
(line (make-line :points (scale-points (line-points primitive))))
|
|
(circle
|
|
(make-circle
|
|
:radius (* scale-factor (circle-radius primitive))
|
|
:centre (scale-points (circle-centre primitive))))
|
|
(polygon
|
|
(make-polygon
|
|
:points (scale-points (polygon-points primitive))))))
|
|
(mapcar #'scale-primitive drawing))
|
|
|
|
(defun overlay (&rest drawings)
|
|
(apply #'append drawings))
|
|
|
|
(defclass graphics-context ()
|
|
(window
|
|
renderer
|
|
(width :initarg :width :initform 800)
|
|
(height :initarg :height :initform 600)))
|
|
|
|
(defmethod initialize-instance :after ((ctx graphics-context) &key)
|
|
(with-slots (window renderer width height) ctx
|
|
(sdl2:init)
|
|
(setf window
|
|
(sdl2:create-window :title "Simulation"
|
|
:w width :h height
|
|
:flags '(:shown)))
|
|
(setf renderer
|
|
(sdl2:create-renderer window -1 '(:accelerated :presentvsync)))))
|
|
|
|
(defmethod cleanup ((ctx graphics-context))
|
|
(with-slots (window renderer) ctx
|
|
(sdl2:destroy-renderer renderer)
|
|
(sdl2:destroy-window window)
|
|
(sdl2:quit)))
|