136 lines
4.7 KiB
Common Lisp
136 lines
4.7 KiB
Common Lisp
;; Copyright (c) Camden Dixie O'Brien
|
|
;; SPDX-License-Identifier: AGPL-3.0-only
|
|
|
|
(in-package :ham)
|
|
|
|
(defstruct line points)
|
|
(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 &optional (segments 32))
|
|
(let ((points (make-array (* segments 2))))
|
|
(dotimes (i segments)
|
|
(let ((angle (* 2 pi (/ i segments))))
|
|
(setf (aref points (* i 2))
|
|
(+ centre-x (* radius (cos angle))))
|
|
(setf (aref points (1+ (* i 2)))
|
|
(+ centre-y (* radius (sin angle))))))
|
|
(list (make-polygon :points points))))
|
|
|
|
(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)))
|
|
|
|
(defmacro define-transform (name (&rest params) &key x-transform y-transform)
|
|
`(defun ,name (,@params drawing)
|
|
(labels ((transform-points (points)
|
|
(let ((new-points (copy-seq points)))
|
|
(do ((i 0 (+ i 2)))
|
|
((>= i (length points)))
|
|
(let ((x (aref new-points i))
|
|
(y (aref new-points (1+ i))))
|
|
(setf (aref new-points i) ,x-transform)
|
|
(setf (aref new-points (1+ i)) ,y-transform)))
|
|
new-points))
|
|
(transform-primitive (primitive)
|
|
(typecase primitive
|
|
(line
|
|
(make-line
|
|
:points (transform-points (line-points primitive))))
|
|
(polygon
|
|
(make-polygon
|
|
:points (transform-points
|
|
(polygon-points primitive)))))))
|
|
(mapcar #'transform-primitive drawing))))
|
|
|
|
(define-transform translate (delta-x delta-y)
|
|
:x-transform (+ delta-x x)
|
|
:y-transform (+ delta-y y))
|
|
|
|
(define-transform scale (scale-factor)
|
|
:x-transform (* scale-factor x)
|
|
:y-transform (* scale-factor y))
|
|
|
|
(define-transform rotate (theta)
|
|
:x-transform (- (* x (cos theta)) (* y (sin theta)))
|
|
:y-transform (+ (* x (sin theta)) (* y (cos theta))))
|
|
|
|
(defun overlay (&rest drawings)
|
|
(apply #'append drawings))
|
|
|
|
(defclass graphics-context ()
|
|
(window
|
|
renderer
|
|
(width :initarg :width)
|
|
(height :initarg :height)))
|
|
|
|
(defmethod initialize-instance :after ((ctx graphics-context) &key)
|
|
(with-slots (window renderer width height) ctx
|
|
(sdl2:init :video)
|
|
(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)))
|
|
|
|
(defmacro with-graphics-context ((var &rest args) &body body)
|
|
`(let ((,var (make-instance 'graphics-context ,@args)))
|
|
(unwind-protect
|
|
(progn ,@body)
|
|
(cleanup ,var))))
|
|
|
|
(define-transform project-to-screen (screen-height)
|
|
:x-transform (round x)
|
|
:y-transform (round (- screen-height y)))
|
|
|
|
(defmethod display-frame ((ctx graphics-context) drawing)
|
|
(with-slots (renderer width height) ctx
|
|
(sdl2:set-render-draw-color renderer 255 255 255 255)
|
|
(sdl2:render-clear renderer)
|
|
(sdl2:set-render-draw-color renderer 0 0 0 255)
|
|
(draw renderer
|
|
(project-to-screen height
|
|
(translate (/ width 2) (/ height 2) drawing)))
|
|
(sdl2:render-present renderer)))
|
|
|
|
(defun draw (renderer drawing)
|
|
(defun draw-line (line)
|
|
(let ((points (line-points line)))
|
|
(sdl2:render-draw-line renderer
|
|
(aref points 0) (aref points 1)
|
|
(aref points 2) (aref points 3))))
|
|
(defun draw-polygon (polygon)
|
|
(let* ((points (polygon-points polygon))
|
|
(point-count (/ (length points) 2)))
|
|
(dotimes (i point-count)
|
|
(let* ((start (* i 2))
|
|
(end (if (= i (1- point-count)) 0 (+ start 2))))
|
|
(sdl2:render-draw-line renderer
|
|
(aref points start)
|
|
(aref points (1+ start))
|
|
(aref points end)
|
|
(aref points (1+ end)))))))
|
|
(dolist (primitive drawing)
|
|
(typecase primitive
|
|
(line (draw-line primitive))
|
|
(polygon (draw-polygon primitive)))))
|