├── .editorconfig ├── .gitignore ├── LICENSE ├── README.org ├── examples ├── brownian.lisp ├── control-flow.lisp ├── hello-world.lisp ├── indigo.lisp ├── input.lisp ├── life.lisp ├── package.lisp ├── sinewave.lisp └── stars.lisp ├── res └── sourcesans │ ├── LICENSE.txt │ ├── SourceSansPro-Black.otf │ ├── SourceSansPro-BlackIt.otf │ ├── SourceSansPro-Bold.otf │ ├── SourceSansPro-BoldIt.otf │ ├── SourceSansPro-ExtraLight.otf │ ├── SourceSansPro-ExtraLightIt.otf │ ├── SourceSansPro-It.otf │ ├── SourceSansPro-Light.otf │ ├── SourceSansPro-LightIt.otf │ ├── SourceSansPro-Regular.otf │ ├── SourceSansPro-Semibold.otf │ └── SourceSansPro-SemiboldIt.otf ├── sketch-examples.asd ├── sketch.asd └── src ├── bindings.lisp ├── canvas.lisp ├── channels.lisp ├── color.lisp ├── complex-transforms.lisp ├── controllers.lisp ├── drawing.lisp ├── entities.lisp ├── environment.lisp ├── figures.lisp ├── font.lisp ├── geometry.lisp ├── image.lisp ├── math.lisp ├── package.lisp ├── pen.lisp ├── resources.lisp ├── shaders.lisp ├── shapes.lisp ├── sketch.lisp ├── transforms.lisp └── utils.lisp /.editorconfig: -------------------------------------------------------------------------------- 1 | # The Essentials 2 | [*] 3 | charset = utf-8 4 | end_of_line = lf 5 | insert_final_newline = true 6 | trim_trailing_whitespace = true 7 | 8 | 9 | # Indentation 10 | [*.asd,*.lisp,*.md] 11 | indent_style = space 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.falsl 3 | *.dx64fsl 4 | .\#* 5 | \#* 6 | *~ 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2023 Danilo Vidovic (vydd) and contributors 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is furnished 8 | to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 17 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * Sketch 2 | 3 | [[http://quickdocs.org/sketch/][file:http://quickdocs.org/badge/sketch.svg]] 4 | 5 | Sketch is a Common Lisp environment for the creation of electronic art, visual design, game prototyping, game making, computer graphics, exploration of human-computer interaction and more. It is inspired by [[https://processing.org][Processing Language]] and shares some of the API. 6 | 7 | [[http://i.imgur.com/MNZUwz8.png]] 8 | 9 | ** Installation 10 | 11 | Sketch is available through [[https://www.quicklisp.org/beta/][Quicklisp]], Common Lisp's de facto package manager. From your REPL, run: 12 | 13 | #+BEGIN_SRC lisp 14 | (ql:quickload :sketch) 15 | #+END_SRC 16 | 17 | To make Sketch run correctly, however, a few requirements must be met. 18 | 19 | *** Requirements 20 | **** Common Lisp Implementation 21 | Sketch should be compatible with all major Common Lisp implementations and all major operating systems - more specifically, all CL implementations and operating systems that [[https://github.com/lispgames/cl-sdl2][cl-sdl2]] runs on. Incompatibility with any of these is considered a bug. 22 | 23 | Sketch is known to work with: 24 | 25 | - CCL 1.11 on Mac OS X El Capitan 26 | - CCL 1.12.1 on MacOS 13.1 ([[https://github.com/vydd/sketch/issues/67][steps]]) 27 | - CCL SVN 1.12.dev.r16617 on Arch Linux 28 | - CCL 1.11 on Windows 10 64bit 29 | - SBCL on Debian Unstable 30 | - SBCL 1.2.16 on Arch Linux 31 | - SBCL 1.3.1 on Linux Mint 17 32 | - SBCL 1.3.6 on Windows 10 64bit 33 | 34 | Workarounds, or extra steps, may be required on some systems: 35 | 36 | - Arch Linux, [[https://github.com/vydd/sketch/issues/16][issue]]. 37 | - OpenSuse, [[https://github.com/vydd/sketch/issues/17][issue]]. 38 | - CCL on OSX: Make sure to use the 64-bit version of CCL ([[https://github.com/vydd/sketch/issues/23][issue]]). 39 | - Quickload fails with libffi error, [[https://github.com/vydd/sketch/issues/47][issue]]. 40 | 41 | Sketch is known to *not* work with: 42 | 43 | - SBCL 1.2.15 on Mac OS X 44 | /Sketch can't handle input and the window's titlebar is black. These kinds of issues are a known problem with Mac OS X, because it needs its GUI threads to be main, and CCL is the only lisp that accounts for that out of the box. There are ways to counter this, but until a solution finds its way into this repository, SBCL on Mac OS X will stay on this list. In the meantime, use CCL./ 45 | 46 | If you test Sketch on other systems, please send a pull request to include your results. 47 | 48 | **** Foreign dependencies 49 | ***** SDL2 50 | SDL2 is currently Sketch's only backend. It is a C library which you will need to download manually from [[https://www.libsdl.org][libsdl webpage]]. Select the release compatible with your operating system, or compile from the source code. 51 | 52 | ***** SDL2 Image & SDL2 TTF 53 | For loading image and font files, Sketch relies on SDL2 Image and SDL2 TTF, respectively, both part of the SDL project. 54 | 55 | ***** libffi 56 | Some users have reported that [[https://sourceware.org/libffi/][libffi]] needed to be installed to make Sketch work. 57 | 58 | ***** OpenGL 59 | Sketch requires graphics hardware and drivers with support for GL version 3.3. 60 | 61 | **** Installing and running Sketch on Windows 62 | Sketch works on both CCL and SBCL, but installing all prerequisites might not be as straightforward as it is on the other platforms. 63 | 64 | ***** Libraries 65 | Download SDL2, SDL2_IMAGE and SDL2_TTF dlls from [[https://www.libsdl.org][libsdl webpage]] and copy them somewhere Windows can find them - =\Windows\System32= will work. When copying SDL2_TTF, make sure to copy all of the dlls provided in the archive, and not just the TTF one. 66 | 67 | Now you will need to get a libffi dll. One of the ways of doing this is compiling from the source, but for a quick and easy solution, you can just find a trusted source and use their version. For example, if you are using Emacs on Windows, you can find =libffi-6.dll= in =emacs\bin=. Copy it to the same directory you copied sdl2 dlls to earlier. 68 | 69 | ***** GCC 70 | To bootstrap cffi-libffi, you are going to need a C compiler, more specifically the one from the GNU Compiler Collection. Also, libffi headers and pkg-config are needed. Luckily, you can get all these things (and more) with MSYS2. Go to [[https://msys2.github.io]] and follow the instructions for installing the 64bit version. 71 | 72 | From its console, install gcc, libffi headers and pkg-config by running =pacman -S gcc libffi libffi-devel pkg-config=. 73 | 74 | ***** Environment variables 75 | From the Control Panel, open System properties, go to the Advanced tab, and click "Environment Variables..." - or click the Start button, start typing "environment" and select "Edit the system environment variables". 76 | 77 | Double click "Path" from the list of System variables and make sure that both your lisp implementation's path (something like =C:\Program Files\Steel Bank Common Lisp\1.3.6\=) and MSYS path (probably =C:\msys64\usr\bin=) are listed. If not, click "New" and add them now. 78 | 79 | If you needed to change anything here, restart the computer now. 80 | 81 | ***** SLIME 82 | If you are using SLIME, you won't be able to load or run Sketch if you start SWANK from emacs (by running =M-x slime=). Instead, you should open the Command Prompt (the regular one, not MSYS), start your lisp and eval =(ql:quickload :swank)= =(swank:create-server)=. From Emacs, type =M-x slime-connect=, and finally, press enter twice (for localhost and port 4005). 83 | 84 | If you did everything correctly, you should be able to =(ql:quickload :sketch)= and move on to the tutorial. 85 | 86 | *** Running provided examples 87 | To get a feel for what Sketch can do, and also to make sure that everything has been installed correctly, run the examples as follows. 88 | 89 | #+BEGIN_SRC lisp 90 | CL-USER> (ql:quickload :sketch-examples) 91 | CL-USER> (make-instance 'sketch-examples:hello-world) 92 | CL-USER> (make-instance 'sketch-examples:sinewave) 93 | CL-USER> (make-instance 'sketch-examples:brownian) 94 | CL-USER> (make-instance 'sketch-examples:life) ; Click to toggle cells, 95 | ; any key to toggle iteration 96 | CL-USER> (make-instance 'sketch-examples:input) 97 | CL-USER> (make-instance 'sketch-examples:stars) 98 | #+END_SRC 99 | 100 | *** Running example code from this page 101 | In all the following examples, we're going to assume that Sketch is loaded with =(ql:quickload :sketch)=, and that we're in package =:TUTORIAL=, which is set to use =:SKETCH=. 102 | 103 | #+BEGIN_SRC lisp 104 | CL-USER> (ql:quickload :sketch) 105 | CL-USER> (defpackage :tutorial (:use :cl :sketch)) 106 | CL-USER> (in-package :tutorial) 107 | TUTORIAL> ;; ready 108 | #+END_SRC 109 | 110 | ** Tutorial 111 | Defining sketches is done with the =defsketch= macro, which is essentially a wrapper for =defclass=. 112 | 113 | #+BEGIN_SRC lisp 114 | (defsketch tutorial ()) 115 | (make-instance 'tutorial) 116 | #+END_SRC 117 | 118 | If all goes well, this should give you an unremarkable gray window. From now on, assuming you're using Emacs + SLIME, or a similarly capable environment, you can just re-evaluate =(defsketch tutorial () )= and the sketch will be restarted without you having to close the window or make another instance of the class. 119 | 120 | *** Shapes 121 | Let's draw something! Drawing code goes inside the body of =defsketch=. 122 | 123 | =(rect x y w h)= draws a rectangle where =x= and =y= specify the top-left corner of the rectangle, and =w= and =h= are the width and height. By default, the origin (0, 0) is at the top-left corner of the drawing area, and the positive y direction is facing down. 124 | 125 | #+BEGIN_SRC lisp 126 | (defsketch tutorial () 127 | (rect 100 100 200 200)) 128 | #+END_SRC 129 | 130 | #+BEGIN_SRC lisp 131 | (defsketch tutorial () 132 | (dotimes (i 10) 133 | (rect 0 (* i 40) (* (+ i 1) 40) 40))) 134 | #+END_SRC 135 | 136 | Something to note: drawing code doesn't need to go into a special function or method, or be explicitly binded to a sketch. =defsketch= is defined as =(defsketch sketch-name bindings &body body)=: that body, and any functions it calls to, is your drawing code. We will get to =bindings= later. 137 | 138 | Circles and ellipses are drawn with =(circle x y r)= and =(ellipse cx cy rx ry)=: 139 | 140 | #+BEGIN_SRC lisp 141 | (defsketch tutorial () 142 | (circle 300 100 50) 143 | (ellipse 200 200 100 50)) 144 | #+END_SRC 145 | 146 | Lines with =(line x1 y1 x2 y2)=: 147 | 148 | #+BEGIN_SRC lisp 149 | (defsketch tutorial () 150 | (line 0 0 400 400) 151 | (line 400 0 0 400)) 152 | #+END_SRC 153 | 154 | Lines with an arbitrary number of segments with =polyline=: 155 | 156 | #+BEGIN_SRC lisp 157 | (defsketch tutorial () 158 | (polyline 100 100 200 150 300 100 159 | 200 200 100 100)) 160 | #+END_SRC 161 | 162 | Arbitrary polygons can be drawn using =(polygon x1 y1 x2 y2 ...)=, the winding rule (how the "inside parts" and "outside parts" are determined) is specified as a pen property (pens will be described in more detail later) and can be one of =(:odd :nonzero :positive :negative :abs-geq-two)=. By default, it's =:nonzero=. 163 | 164 | #+BEGIN_SRC lisp 165 | (defsketch tutorial () 166 | (with-pen (make-pen :fill +blue+ :winding-rule :odd) 167 | (polygon 100 100 200 150 300 100 200 200))) 168 | #+END_SRC 169 | 170 | To draw a regular polygon with =n= sides, call =(ngon n cx cy rx ry &optional (angle 0))=; =cx= and =cy= are the coordinates of the center of the shape, while =rx= and =ry= are height of an ellipse that the shape is inscribed inside. 171 | 172 | #+BEGIN_SRC lisp 173 | (defsketch tutorial () 174 | (dotimes (i 4) 175 | (ngon (+ i 3) (+ 50 (* i 100)) 200 20 20 (* i 20)))) 176 | #+END_SRC 177 | 178 | Bezier curves with 4 control points are drawn with =(bezier x1 y1 bx1 by1 bx2 by2 x2 y2)=; =x1=, =y1=, =x2= and =y2= determine the start and end points. 179 | 180 | #+BEGIN_SRC lisp 181 | (defsketch tutorial () 182 | (bezier 0 400 100 100 300 100 400 400)) 183 | #+END_SRC 184 | 185 | The resolution of a curve can be controlled with the pen property =:curve-steps=, for example: 186 | 187 | #+BEGIN_SRC lisp 188 | (defsketch tutorial () 189 | (with-pen (make-pen :curve-steps 4 :stroke +white+) 190 | (bezier 0 400 100 100 300 100 400 400))) 191 | #+END_SRC 192 | 193 | *** Configuring your sketch 194 | The first form in =defsketch= after the name of your sketch, and before the body, is a list of bindings that will be available in the sketch body. This is also where a number of configuration options can be set: 195 | 196 | - =title= (string): window title. 197 | - =width= and =height= (in pixels): window dimensions, 400 x 400 by default. 198 | - =fullscreen= (=t= or =nil=): whether window is fullscreen. 199 | - =resizable= (=t= or =nil=): whether window is resizable. 200 | - =copy-pixels= (=t= or =nil=): if true, the screen is not cleared before each drawing loop. 201 | - =y-axis= (=:down= or =:up=): =:down= by default. Determines both the location of the origin and the positive direction of the y-axis. =:down= means (0,0) is in the top-left corner and greater values of =y= move down the screen. =:up= means (0,0) is in the bottom-left corner and greater =y= values go up. 202 | - =close-on= (a keyword symbol denoting a key, or =nil= to disable): a shortcut for closing the sketch window, =:escape= by default. Set to =nil= to disable. The key names (e.g. =:space=, =:g=) are based on SDL2 scancodes, see [[https://wiki.libsdl.org/SDL2/SDL_Scancode][here]]. 203 | 204 | #+BEGIN_SRC lisp 205 | (defsketch tutorial 206 | ((radius 10) 207 | (resizable t) 208 | (width 200)) 209 | (circle (/ width 2) (/ radius 2) radius)) 210 | #+END_SRC 211 | 212 | *** Colors 213 | In the previous examples, you may have noticed how to draw a shape with a fill color. Let's now explore the color capabilities of Sketch in more detail. To draw a yellow background: 214 | 215 | #+BEGIN_SRC lisp 216 | (defsketch tutorial () 217 | (background +yellow+)) 218 | #+END_SRC 219 | 220 | **** Predefined colors 221 | There are constants for commonly used colors: =+RED+=, =+GREEN+=, =+BLUE+=, =+YELLOW+=, =+MAGENTA+=, =+CYAN+=, =+ORANGE+= =+WHITE+=, and =+BLACK+=. 222 | 223 | **** RGB, HSB, GRAY 224 | You can create other colors using =(rgb red green blue &optional (alpha 1.0))=, =(hsb hue saturation brightness &optional (alpha 1.0))= or =(gray amount &optional (alpha 1.0))=. The arguments to these functions are values from 0 to 1. =(gray amount &optional (alpha 1.0))= is really just a convenient alias for =(rgb amount amount amount &optional (alpha 1.0))=. 225 | 226 | More information: 227 | 228 | - [[https://en.wikipedia.org/wiki/RGB_color_model][RGB color model]] 229 | - [[https://en.wikipedia.org/wiki/HSL_and_HSV][HSB / HSV]]. 230 | 231 | /This might be a good place to note that function names in Sketch use the American English spellings, like "gray" and "color". It's just a choice that needed to be made, in pursuit of uniformity and good style./ 232 | 233 | For a lighter yellow: 234 | 235 | #+BEGIN_SRC lisp 236 | (defsketch tutorial () 237 | (background (rgb 1 1 0.5))) 238 | #+END_SRC 239 | 240 | All color functions have an additional =ALPHA= parameter that determines the transparency. 241 | 242 | **** RGB-255, HSB-360, GRAY-255 243 | Sometimes it's easier to think about color values in non-normalized ranges. That's why Sketch offers =RGB-255=, =HSB-360=, and =GRAY-255=. 244 | 245 | This is how these functions map to their normalized variants. 246 | 247 | | (rgb-255 r g b a) | (rgb (/ r 255) (/ g 255) (/ b 255) (/ a 255)) | 248 | | (hsb-360 h s b a) | (hsb (/ h 360) (/ s 100) (/ b 100) (/ a 255)) | 249 | | (gray-255 g a) | (gray (/ g 255) (/ a 255)) | 250 | 251 | =HSB-360= uses different ranges, because hue is represented in degrees (0-360), and saturation and brightness are represented as percentages (0-100). 252 | 253 | **** HEX-TO-COLOR 254 | If you are used to working with colors in hex, like in CSS, you can use =(hex-to-color string)=, where =STRING= is the color in one of the following formats: "4bc", "#4bc", "4bcdef", or "#4bcdef". 255 | 256 | **** Generating colors 257 | If you don't care about fiddling with the exact values, but still need different colors, you can use one of the following functions. 258 | 259 | ***** =(lerp-color (start-color end-color amount &key (mode :hsb)))= 260 | Lerp is a shorthand for [[https://en.wikipedia.org/wiki/Linear_interpolation][linear interpolation]]. This function takes the starting color and the ending color, and returns the color between them, which is an =AMOUNT= away from the starting color. When =AMOUNT= equals zero, the returned color equals the starting color, and when =AMOUNT= equals one, the ending color is returned. Amounts between zero and one give colors that are "in-between". These colors are calculated according to the specified =MODE=, which is =:HSB= by default, meaning that the resulting color's hue is between the starting and ending hue, as is the case with its saturation and brightness. 261 | 262 | #+BEGIN_SRC lisp 263 | (defsketch lerp-test ((title "lerp-color") (width 400) (height 100)) 264 | (dotimes (i 4) 265 | (with-pen (make-pen :fill (lerp-color +red+ +yellow+ (/ i 4))) 266 | (rect (* i 100) 0 100 100)))) 267 | #+END_SRC 268 | 269 | ***** =(random-color (&optional (alpha 1.0)))= 270 | Returns a random color. You probably don't want to use this, because many of the returned colors will be either too dark, or too light. You do get to choose the =ALPHA= value, though. 271 | 272 | #+BEGIN_SRC lisp 273 | (defparameter *colors* (loop for i below 16 collect (random-color))) 274 | 275 | (defsketch random-color-test ((title "random-color") (width 400) (height 100)) 276 | (dotimes (x 8) 277 | (dotimes (y 2) 278 | (with-pen (make-pen :fill (elt *colors* (+ x (* y 8)))) 279 | (rect (* x 50) (* y 50) 50 50))))) 280 | #+END_SRC 281 | 282 | ***** =(hash-color (n &optional (alpha 1.0)))= 283 | This is probably the function you're looking for, if you just want to create a non-repeating set of colors quickly. It maps all numbers to "interesting" (not too dark, not too light) colors. You can use this for coloring procedurally generated objects, when prototyping and just trying to make things look different quickly, when making palettes, looking for "the right" color, and many other things. 284 | 285 | #+BEGIN_SRC lisp 286 | (defsketch hash-color-test ((title "hash-color") (width 400) (height 100)) 287 | (dotimes (i 128) 288 | (with-pen (make-pen :fill (hash-color i)) 289 | (rect (* i (/ 400 128)) 0 (/ 400 128) 100)))) 290 | #+END_SRC 291 | 292 | **** Color filters 293 | Sometimes you have a color, and would like to transform it in some way. That's what color filters are for. 294 | 295 | ***** Grayscale 296 | To convert colors to grayscale, you can use =color-filter-grayscale=. Two modes of grayscale conversion are implemented: 297 | 298 | - =:luminosity=, the default, which is [[https://en.wikipedia.org/wiki/Grayscale#Colorimetric_.28luminance-preserving.29_conversion_to_grayscale][luminance-preserving]] 299 | - =:average=, which sets all color channels to their average 300 | 301 | #+BEGIN_SRC lisp 302 | (defsketch grayscale-test ((title "grayscale") (width 400) (height 300)) 303 | (dotimes (i 10) 304 | (let ((color (hash-color i))) 305 | (with-pen (make-pen :fill (color-filter-grayscale color)) 306 | (rect (* i 40) 0 40 100)) 307 | (with-pen (make-pen :fill color) 308 | (rect (* i 40) 100 40 100)) 309 | (with-pen (make-pen :fill (color-filter-grayscale color :average)) 310 | (rect (* i 40) 200 40 100))))) 311 | #+END_SRC 312 | 313 | ***** Invert 314 | To invert a color, use =color-filter-invert=: 315 | 316 | #+BEGIN_SRC lisp 317 | (defsketch invert-test 318 | ((title "invert") (width 300) (height 300) (i 0)) 319 | (background +white+) 320 | (incf i 0.01) 321 | (let ((color (rgb (abs (sin i)) (abs (cos i)) 0))) 322 | (with-pen (make-pen :fill color) 323 | (circle 100 150 50)) 324 | (with-pen (make-pen :fill (color-filter-invert color)) 325 | (circle 200 150 50)))) 326 | #+END_SRC 327 | 328 | ***** Rotate 329 | Rotating a color in Sketch using =color-filter-rotate= sets the value of its red channel to the 330 | previous value of the green channel; green to blue, and blue to 331 | red. The operation is intended to be used in palette generation, 332 | because the rotated colors usually work pretty well together. 333 | 334 | #+BEGIN_SRC lisp 335 | (defsketch rotate-test 336 | ((title "rotate") (width 300) (height 300) 337 | (i 0) (color (rgb 0.2 0.8 1.0))) 338 | (background +white+) 339 | (incf i 1) 340 | (when (zerop (mod i 60)) 341 | (setf color (color-filter-rotate color))) 342 | (with-pen (make-pen :fill color) 343 | (rect 100 100 100 100))) 344 | #+END_SRC 345 | 346 | ***** HSB 347 | [[https://en.wikipedia.org/wiki/HSL_and_HSV][HSB]] stands for Hue/Saturation/Brightness. You can use 348 | =color-filter-hsb= to adjust hue, saturation and brightness of an existing color. 349 | 350 | #+BEGIN_SRC lisp 351 | (defsketch hsb-test 352 | ((title "hsb") (width 400) (height 300) (color (rgb 0.2 0.5 0.6))) 353 | (dotimes (i 4) 354 | (with-pen (make-pen :fill (color-filter-hsb color :hue (* 0.1 (+ i 1)))) 355 | (rect (* i 100) 0 100 100)) 356 | (with-pen (make-pen :fill (color-filter-hsb color :saturation (* 0.1 (+ i 1)))) 357 | (rect (* i 100) 100 100 100)) 358 | (with-pen (make-pen :fill (color-filter-hsb color :brightness (* 0.1 (+ i 1)))) 359 | (rect (* i 100) 200 100 100)))) 360 | #+END_SRC 361 | 362 | *** Pens 363 | Pens are used to draw shapes. If no pen is specified, the default pen sets =:fill= to white, =:stroke= to black, and =weight= to 1. 364 | 365 | ***** Creating and Using Pens 366 | Say you want to draw a red square and a blue circle. You would need to use two different pens. 367 | #+BEGIN_SRC lisp 368 | (defsketch pen-test 369 | ((title "pens")) 370 | (with-pen (make-pen :fill +red+) 371 | (rect 100 100 100 100)) ; this rect will be red 372 | (with-pen (make-pen :fill +blue+) 373 | (circle 315 315 50))) ; this rect will be blue 374 | #+END_SRC 375 | 376 | ***** Fill/Stroke 377 | The squares in the previous example were filled because we specified the =:fill= property in =make-pen=. 378 | If we wanted to just draw the outline of the square, we would use =:stroke= like this: 379 | #+BEGIN_SRC lisp 380 | (defsketch outline-square 381 | ((title "Outline Square")) 382 | (with-pen (make-pen :stroke +red+) 383 | (rect 100 100 100 100))) 384 | #+END_SRC 385 | #+BEGIN_SRC lisp 386 | (defsketch fill-stroke 387 | ((title "Fill and Stroke")) 388 | (background +white+) 389 | (with-pen (make-pen :stroke (rgb .5 0 .6) :fill (rgb 0 .8 .8)) 390 | (rect 50 50 100 75) 391 | (circle 300 220 100))) 392 | #+END_SRC 393 | 394 | ***** Weight 395 | We can also change the thickness of the lines and shapes that we draw by changing the pen =:weight=. 396 | #+BEGIN_SRC lisp 397 | (defsketch weight-test 398 | ((title "Weight Test")) 399 | (dotimes (i 10) 400 | (with-pen (make-pen :stroke +white+ :weight (+ i 1)) ; pen weight can't be zero 401 | (line 50 (* i 20) 350 (* i 20))))) 402 | #+END_SRC 403 | 404 | **** Curve-steps 405 | =:curve-steps= is used to change the smoothness (resolution) of curves like =#'bezier=. 406 | #+BEGIN_SRC lisp 407 | (defsketch curve-test 408 | ((title "Curve-steps")) 409 | (dotimes (i 99) 410 | (with-pen (make-pen :stroke +red+ :curve-steps (+ i 1)) ; as curve-step increases, curve becomes "smoother" 411 | (bezier 0 400 100 100 300 100 400 400)))) 412 | #+END_SRC 413 | 414 | *** Transforms 415 | The transforms =(translate dx dy)=, =(rotate angle &optional (cx 0) (cy 0))= and =(scale sx &optional sy (cx 0) (cy 0))= are available to change the view matrix that is applied to coordinates. 416 | 417 | Macros =(with-translate (dx dy) &body body)=, =(with-rotate (angle &optional (cx 0) (cy 0)) &body body)= and =(with-scale (sx &optional sy (cx 0) (cy 0)) &body body)= can be used to restore the view matrix after executing the body. 418 | 419 | The current view can also be saved on a stack and restored with =(push-matrix)= and =(pop-matrix)=, which are analogous to =push()= and =pop()= in p5.js. The macro =(with-identity-matrix &body body)= pushes the current view matrix onto the stack, sets the view matrix to the identity matrix, executes =body=, and then pops the view matrix. =(with-current-matrix &body body)= is the same, except it doesn't change the view matrix after pushing it. 420 | 421 | In this example, translation and rotation are used to draw a triangle in the centre of the screen, without explicitly defining the coordinates of the vertices. 422 | 423 | #+BEGIN_SRC lisp 424 | (defsketch transform-test 425 | ((title "Transform test") 426 | (width 500) 427 | (height 500) 428 | (side 100) 429 | (y-offset (/ side (* 2 (tan (radians 60)))))) 430 | (with-translate (250 250) 431 | (loop repeat 3 432 | do (line (- (* 1/2 side)) y-offset (* 1/2 side) y-offset) 433 | do (rotate 120)))) 434 | #+END_SRC 435 | 436 | This example draws a sequence of increasingly shrinking squares using scaling. 437 | 438 | #+BEGIN_SRC lisp 439 | (defsketch transform-test 440 | ((width 400) 441 | (height 400) 442 | (title "Scale test")) 443 | (translate 100 100) 444 | (dotimes (x 5) 445 | (rect 0 0 100 100) 446 | (translate 150 0) 447 | (scale 1/2))) 448 | #+END_SRC 449 | 450 | *** Text 451 | Use =(text text-string x y &optional width height)= to draw text, where =x= and =y= specify the top-left corner of the rectangle containing the text. =width= and =height= control the shape of the text box. There is support for changing the [[https://github.com/vydd/sketch/blob/master/src/font.lisp#L29][font]]. 452 | 453 | #+BEGIN_SRC lisp 454 | (defsketch text-test 455 | ((title "Hello, world!")) 456 | (text title 0 0 100)) 457 | #+END_SRC 458 | 459 | The font can be specified using =(make-font &key face color size line-height align)= and the =with-font= macro. 460 | 461 | #+BEGIN_SRC lisp 462 | (defsketch text-test 463 | ((title (format nil "Hello, world!~%Next line")) 464 | (with-font (make-font :color +white+ 465 | :face (load-resource "/path/to/font.ttf") 466 | :size 12 467 | :line-height 1 468 | :align :left) 469 | (text title 0 0 100))) 470 | #+END_SRC 471 | 472 | =align= can be =:left=, =:centre= or =:right=, and determines whether the x & y coordinates correspond to the left end, centre, or right end of the text box. =line-height= determines the vertical space given to a line of text, scaled according to the font size, i.e. =:line-height 1= leaves just enough space so that the text on two lines won't overlap. 473 | 474 | *** Images 475 | First =(load-resource filename ...)= to load the image from a given file, then =(draw image &key x y width height)= to draw the image with its top-left corner at =(x, y)= and with the given =width= and =height=. If not provided, default =(x,y)= is =(0,0)= and =width= & =height= are taken from the image. 476 | 477 | #+BEGIN_SRC lisp 478 | (defsketch image-test 479 | ((title "Hello, image!") 480 | (pic (load-resource "/path/to/img.png"))) 481 | (draw pic :x 10 :y 10 :width 200 :height 200)) 482 | #+END_SRC 483 | 484 | Note that =load-resource= automatically caches the resource when it is called inside a valid sketch environment (i.e. inside the defsketch's body), so it is not inefficient to call it in every loop. It is important to release resources using =sketch::free-resource=; this is done automatically for resources in the sketch environment when the sketch window is closed. Finally, to avoid caching and to reload the resource every time, the parameter =:force-reload-p= can be passed to =load-resource=. 485 | 486 | Images can be cropped using =(crop image x y w h)=, where =x= and =y= indicate the top-left corner of the cropping rectangle (relative to the top-left corner of the image) and =w= and =h= indicate the width & height. Image flipping can be accomplished by using negative =w= and =h= values. 487 | 488 | *** Input 489 | Input is handled by defining implementations of the methods listed below. Currently, it is not possible to call drawing functions from these methods, though this can be worked around by saving the input somewhere and then doing the drawing from the sketch body, as demonstrated in the examples to follow. 490 | 491 | - =(on-click instance x y)=, =(on-middle-click x y)= and =(on-right-click x y)= are called when there's a left, middle or right click. =x= and =y= give the coordinates of the click. 492 | - =(on-mouse-button button state x y)= is called for left, middle and right mousebutton interactions. =button= can be one of =:left=, =:middle= and =:right=. =state= can be either =:up= or =:down=. 493 | - Depending on the value of =button=, this propagates to one of: =(on-mouse-left state x y)=, =(on-mouse-middle state x y)=, or =(on-mouse-right state x y)=. 494 | - These methods, in turn, propagate to =(on-mouse-left-up x y)=, =(on-mouse-right-down x y)=, =(on-mouse-right-down x y)=, ... 495 | - =(on-hover instance x y)= is called when the mouse moves, =x= and =y= give its coordinates. 496 | - =(on-text instance text)= is called when a single character is entered, =text= is a string consisting of just this character. 497 | - =(on-key instance key state)= is called when a key is pressed. =key= is a keyword symbol denoting which key was pressed/released (like =:space= or =:left=; for now, the names are based on SDL2 scancodes, see [[https://wiki.libsdl.org/SDL2/SDL_Scancode][here]] for the full list), and =state= is a keyword symbol denoting whether the key was pressed (=:up=) or released (=:down=). 498 | 499 | In this example, we draw a new rectangle every time there is a click. 500 | 501 | #+BEGIN_SRC lisp 502 | (defsketch input-test 503 | ((title "Hello, input") 504 | (rectangles nil)) 505 | (loop for (x y) in rectangles 506 | do (rect x y 50 50))) 507 | (defmethod on-click ((window input-test) x y) 508 | (with-slots (rectangles) window 509 | (push (list x y) rectangles))) 510 | #+END_SRC 511 | 512 | In this example, all keyboard text input is echoed to the screen. 513 | 514 | #+BEGIN_SRC lisp 515 | (defsketch text-test 516 | ((title "Hello, input") 517 | (text-to-write nil)) 518 | (loop for s in text-to-write 519 | do (text s 0 0 20 20) 520 | do (translate 20 0))) 521 | (defmethod on-text ((window text-test) text) 522 | (with-slots (text-to-write) window 523 | (setf text-to-write (nconc text-to-write (list text))))) 524 | #+END_SRC 525 | 526 | Finally, here is an example where a pair of eyes follow the mouse (the pupils are restricted to a rectangle, it would look better if they were restricted to a circle). 527 | 528 | #+BEGIN_SRC lisp 529 | (defsketch hover-test 530 | ((looking-at (list 0 0)) 531 | (cx (/ width 2)) 532 | (cy (/ height 2))) 533 | (let ((cx-1 (- cx 50)) 534 | (cx-2 (+ cx 50)) 535 | (mx (car looking-at)) 536 | (my (cadr looking-at))) 537 | (with-pen (make-pen :fill +white+) 538 | (ellipse cx-1 cy 40 80) 539 | (ellipse cx-2 cy 40 80)) 540 | (with-pen (make-pen :fill +black+) 541 | (flet ((move-towards (x1 x2) 542 | (let ((diff (- x2 x1))) 543 | (+ x1 (if (< (abs diff) 10) 544 | diff 545 | (* (signum diff) 10)))))) 546 | (circle (move-towards cx-1 mx) (move-towards cy my) 10) 547 | (circle (move-towards cx-2 mx) (move-towards cy my) 10))))) 548 | (defmethod on-hover ((window hover-test) x y) 549 | (with-slots (looking-at) window 550 | (setf (car looking-at) x 551 | (cadr looking-at) y))) 552 | #+END_SRC 553 | 554 | See also: [[https://github.com/vydd/sketch/blob/master/examples/life.lisp][life.lisp]]. 555 | 556 | *** Setup 557 | The generic function =(setup instance &key &allow-other-keys)= is a hook that gets called once on every "restart" of the sketch. That is: 558 | 559 | - before the drawing code in the sketch body is called for the first time. 560 | - whenever the sketch is redefined. 561 | - every time an error occurs. 562 | 563 | Note that any drawing that takes place within =setup= will be immediately covered by a gray background, unless =(copy-pixels t)= is added to =defsketch=. 564 | 565 | Here is an example usage of =setup= from [[https://github.com/vydd/sketch/blob/master/examples/brownian.lisp][brownian.lisp]]. 566 | 567 | #+BEGIN_SRC lisp 568 | (defmethod setup ((instance brownian) &key &allow-other-keys) 569 | (background (gray 1))) 570 | #+END_SRC 571 | 572 | *** Saving a picture 573 | =(save-png pathname)= can be called within the body of =defsketch= to save a PNG of the currently running sketch. A keyboard shortcut could be set up to take screenshots, as follows. 574 | 575 | #+BEGIN_SRC lisp 576 | (defsketch save-test 577 | ((should-save nil) 578 | (copy-pixels t)) 579 | (rect (random width) (random height) 10 10) 580 | (when should-save 581 | (setf should-save nil) 582 | (save-png "/tmp/my-sketch.png"))) 583 | (defmethod on-text ((window save-test) text) 584 | (when (string= text "s") 585 | (setf (slot-value window 'should-save) t))) 586 | #+END_SRC 587 | 588 | *** Drawing with a canvas 589 | =(make-canvas width height)= can be used to create a rectangular grid of pixels. The shape of the grid is defined by =width= and =height=. 590 | 591 | =(canvas-paint canvas color x y)= sets the color of a pixel within the grid. 592 | 593 | =(canvas-lock canvas)= freezes the appearance of the canvas. Any calls to =(canvas-image canvas)= will show an image of the canvas when =canvas-lock= was last called. 594 | 595 | =(canvas-unlock canvas)= allows the image of the canvas to be modified again. 596 | 597 | =(draw canvas &key (x 0) (y 0) (width nil) (height nil)= draws the canvas; by default, the original width and height of the canvas are used, but these can be overridden. 598 | 599 | Example: [[https://github.com/vydd/sketch/blob/master/examples/stars.lisp][stars.lisp]]. 600 | 601 | *** Control flow 602 | =(stop-loop)= from within a sketch body or within an event handler to disable the drawing loop. 603 | 604 | =(start-loop)= to start the drawing loop again. 605 | 606 | This can be used, for example, to draw a static sketch and then disable the drawing loop so as to not burn up your CPU. It can also be used to regenerate the sketch with each mouseclick. 607 | 608 | Example: [[https://github.com/vydd/sketch/blob/master/examples/control-flow.lisp][control-flow.lisp]]. 609 | 610 | ** Made with Sketch 611 | - [[https://vydd.itch.io/qelt][QELT]] 612 | - [[https://github.com/sjl/coding-math][sjl's implementation of coding math videos]] 613 | - [[https://github.com/bufferswap/crawler2][Visual examples for axion's crawler2 library]] 614 | - [[https://github.com/Kevinpgalligan/sketches][Generative art and other experiments by Kevin.]] 615 | 616 | ** Outro 617 | For everything else, read the code or ask vydd at #lispgames. Go make something pretty! 618 | -------------------------------------------------------------------------------- /examples/brownian.lisp: -------------------------------------------------------------------------------- 1 | ;;;; brownian.lisp 2 | 3 | (in-package #:sketch-examples) 4 | 5 | ;; ____ ____ _____ ___ _ ___ _ _ _ 6 | ;; | __ )| _ \ / _ \ \ / / \ | |_ _| / \ | \ | | 7 | ;; | _ \| |_) | | | \ \ /\ / /| \| || | / _ \ | \| | 8 | ;; | |_) | _ <| |_| |\ V V / | |\ || | / ___ \| |\ | 9 | ;; |____/|_| \_\\___/ \_/\_/ |_| \_|___/_/ \_\_| \_| 10 | 11 | (defsketch brownian 12 | ((title "Brownian") 13 | (width 800) 14 | (height 600) 15 | (copy-pixels t) 16 | (pos (cons (/ width 2) (/ height 2))) (dir '(1 . 0)) 17 | (pen (make-pen :stroke (gray 0.5) :fill (gray 0.5) :weight 1)) 18 | (line-length 3) 19 | (points (make-array 256 :initial-element (cons 400 300))) 20 | (points-pointer 0)) 21 | (flet ((draw (paces) 22 | (dotimes (i paces) 23 | (let ((new-pos (cons (+ (car pos) (car dir)) 24 | (+ (cdr pos) (cdr dir))))) 25 | (with-pen pen 26 | (line (car pos) (cdr pos) (car new-pos) (cdr new-pos))) 27 | (setf pos new-pos)))) 28 | (rotate (a) 29 | (let ((a (+ a (degrees (atan (cdr dir) (car dir)))))) 30 | (setf dir (cons (cos (radians a)) 31 | (sin (radians a))))))) 32 | (rotate (- (random 180) 90)) 33 | (draw (+ (random line-length) line-length)) 34 | (setf (car pos) (alexandria:clamp (car pos) -10 810) 35 | (cdr pos) (alexandria:clamp (cdr pos) -10 610)))) 36 | 37 | (defmethod setup ((instance brownian) &key &allow-other-keys) 38 | (background (gray 1))) 39 | -------------------------------------------------------------------------------- /examples/control-flow.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:sketch-examples) 2 | 3 | ;; Regenerate the sketch, drawing a circle in a new place, every 4 | ;; time there's a click. 5 | 6 | (defsketch control-flow 7 | ((title "Control Flow") 8 | (width 400) 9 | (height 400)) 10 | (circle (random width) (random height) 20) 11 | (stop-loop)) 12 | 13 | (defmethod on-click ((sketch control-flow) x y) 14 | (start-loop)) 15 | -------------------------------------------------------------------------------- /examples/hello-world.lisp: -------------------------------------------------------------------------------- 1 | ;;;; hello-world.lisp 2 | 3 | (in-package #:sketch-examples) 4 | 5 | ;;; _ _ _____ _ _ ___ __ _____ ____ _ ____ 6 | ;;; | | | | ____| | | | / _ \ \ \ / / _ \| _ \| | | _ \ 7 | ;;; | |_| | _| | | | | | | | | \ \ /\ / / | | | |_) | | | | | | 8 | ;;; | _ | |___| |___| |__| |_| | \ V V /| |_| | _ <| |___| |_| | 9 | ;;; |_| |_|_____|_____|_____\___/ \_/\_/ \___/|_| \_\_____|____/ 10 | 11 | (defsketch hello-world 12 | ((title "Hello, world!") 13 | (unit (/ width 10)) 14 | (height width)) 15 | (background (gray 0.6)) 16 | (with-pen (make-pen :fill (rgb 0.380 0.695 0.086) :stroke (rgb 1 1 0) :weight 4) 17 | (polygon (* 5 unit) unit unit (* 9 unit) (* 9 unit) (* 9 unit)) 18 | (text title 20 20))) 19 | -------------------------------------------------------------------------------- /examples/indigo.lisp: -------------------------------------------------------------------------------- 1 | ;;;; indigo.lisp 2 | 3 | (in-package #:sketch-examples) 4 | 5 | ;;; ___ _ _ ____ ___ ____ ___ 6 | ;;; |_ _| \ | | _ \_ _/ ___|/ _ \ 7 | ;;; | || \| | | | | | | _| | | | 8 | ;;; | || |\ | |_| | | |_| | |_| | 9 | ;;; |___|_| \_|____/___\____|\___/ 10 | 11 | (defsketch indigo 12 | ((title "Indigo") 13 | (copy-pixels t) 14 | (a 0) (inc 20) (lx 200) (ly 200)) 15 | (set-pen (make-pen :weight 2 :stroke +white+)) 16 | (scale 0.5 0.5 200 200) 17 | (incf a inc) 18 | (rotate a 200 200) 19 | (line 0 0 lx ly) 20 | (rect -50 -50 100 100)) 21 | 22 | (defmethod setup ((indigo indigo) &key &allow-other-keys) 23 | (background +indigo+) 24 | (with-font (make-font :color +white+) 25 | (text "Click to redraw!" 10 10))) 26 | 27 | (defmethod on-click ((indigo indigo) x y) 28 | (background +indigo+) 29 | (with-slots (inc lx ly) indigo 30 | (setf inc (+ (random 100) 1) 31 | lx (+ (random 100) 100) 32 | ly (+ (random 100) 100)))) 33 | -------------------------------------------------------------------------------- /examples/input.lisp: -------------------------------------------------------------------------------- 1 | ;;; input.lisp 2 | 3 | (in-package #:sketch-examples) 4 | 5 | ;; ___ _ _ ____ _ _ _____ 6 | ;; |_ _| \ | | _ \| | | |_ _| 7 | ;; | || \| | |_) | | | | | | 8 | ;; | || |\ | __/| |_| | | | 9 | ;; |___|_| \_|_| \___/ |_| 10 | 11 | ;;; WIP 12 | 13 | (defsketch input 14 | ((title "Input") 15 | (x 0) (y 0) (w 10) (h 10) (r 0) (c 0)) 16 | (background (rgb 1 1 1)) 17 | (translate (+ 200 (- x (/ w 2))) (+ 200 (- y (/ h 2)))) 18 | (rotate r (/ w 2) (/ h 2)) 19 | (with-pen (make-pen :fill (rgb-255 c 40 40)) 20 | (rect 0 0 w h))) 21 | 22 | (defmethod kit.sdl2:controller-axis-motion-event ((win ctest) controller timestamp axis value) 23 | (with-slots (x y w h r c) win 24 | (case axis 25 | (0 (setf x (/ value 100))) 26 | (1 (setf y (/ value 100))) 27 | (2 (setf w (max 50 (abs (/ value 100))))) 28 | (3 (setf h (max 50 (abs (/ value 100))))) 29 | (4 (setf r (abs (/ value 100)))) 30 | (5 (setf c (min (/ value 100) 255)))))) 31 | 32 | (defmethod kit.sdl2:controller-button-event ((win ctest) controller state timestamp button) 33 | (when (eql state :controllerbuttonup) 34 | (format t "(B ~a ~a ~a) " button state (type-of button)) 35 | (finish-output))) 36 | -------------------------------------------------------------------------------- /examples/life.lisp: -------------------------------------------------------------------------------- 1 | ;;;; life.lisp 2 | 3 | (in-package #:sketch-examples) 4 | 5 | ;;; _ ___ _____ _____ 6 | ;;; | | |_ _| ___| ____| 7 | ;;; | | | || |_ | _| 8 | ;;; | |___ | || _| | |___ 9 | ;;; |_____|___|_| |_____| 10 | 11 | ;;; Press any key to toggle between editing and iterating. 12 | ;;; When in edit mode, click on cells to toggle them. 13 | 14 | (defsketch life 15 | ((title "Conway's Game of Life") 16 | (columns 30) 17 | (rows 30) 18 | (cell-size 15) 19 | (width (* columns cell-size)) 20 | (height (* rows cell-size)) 21 | (cells (make-array `(,(+ 2 rows) ,(+ 2 columns) 2) 22 | :initial-element 0 23 | :element-type '(mod 2))) 24 | (front 0) 25 | (color-bg (gray 0.2)) 26 | (pen-dead (make-pen :fill (gray 0))) 27 | (pen-alive (make-pen :fill (gray 0.5))) 28 | (running nil)) 29 | (labels ((neighbors (x y) 30 | (let ((acc 0)) 31 | (dotimes (i 3) 32 | (dotimes (j 3) 33 | (setf acc (+ acc (aref cells (+ i y) (+ j x) front))))) 34 | (- acc (aref cells (1+ y) (1+ x) front)))) 35 | (alivep (x y) 36 | (= 1 (aref cells (1+ y) (1+ x) front))) 37 | (next-state (x y) 38 | (let ((alive (alivep x y)) (neighbors (neighbors x y))) 39 | (if (or (and alive (<= 2 neighbors 3)) 40 | (and (not alive) (= 3 neighbors))) 41 | 1 0)))) 42 | (background color-bg) 43 | (dotimes (y rows) 44 | (dotimes (x columns) 45 | (with-pen (if (zerop (aref cells (1+ y) (1+ x) front)) 46 | pen-dead 47 | pen-alive) 48 | (ellipse (+ (/ cell-size 2) (* x cell-size)) 49 | (+ (/ cell-size 2) (* y cell-size)) 50 | (/ cell-size 3) 51 | (/ cell-size 3))) 52 | (setf (aref cells (1+ y) (1+ x) (mod (1+ front) 2)) 53 | (next-state x y)))) 54 | (when running 55 | (setf front (mod (1+ front) 2))))) 56 | 57 | (defmethod on-text ((instance life) text) 58 | (with-slots (running) instance 59 | (setf running (not running)))) 60 | 61 | (defmethod on-click ((instance life) x y) 62 | (with-slots (cells front running cell-size) instance 63 | (when (not running) 64 | (let ((cy (1+ (truncate (/ y cell-size)))) 65 | (cx (1+ (truncate (/ x cell-size))))) 66 | (setf (aref cells cy cx front) 67 | (mod (1+ (aref cells cy cx front)) 2)))))) 68 | -------------------------------------------------------------------------------- /examples/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage #:sketch-examples 4 | (:use #:cl #:sketch) 5 | (:export :brownian 6 | :hello-world 7 | :life 8 | :sinewave 9 | :stars 10 | :indigo 11 | :control-flow 12 | )) 13 | -------------------------------------------------------------------------------- /examples/sinewave.lisp: -------------------------------------------------------------------------------- 1 | ;;;; sinewave.lisp 2 | 3 | (in-package #:sketch-examples) 4 | 5 | ;;; ____ ___ _ _ _______ _____ _______ 6 | ;;; / ___|_ _| \ | | ____\ \ / / \ \ / / ____| 7 | ;;; \___ \| || \| | _| \ \ /\ / / _ \ \ / /| _| 8 | ;;; ___) | || |\ | |___ \ V V / ___ \ V / | |___ 9 | ;;; |____/___|_| \_|_____| \_/\_/_/ \_\_/ |_____| 10 | 11 | (defsketch sinewave 12 | ((title "Sinewave") (width 400) (height 400) 13 | (steps 0) (xs (/ width 5)) (r 3)) 14 | (incf steps) 15 | (background (rgb 0.2 0.2 0.2)) 16 | (let ((w width) (h height)) 17 | (flet ((sin-calc (x) 18 | (sin (* +tau+ (/ (+ (/ steps 4) x) xs))))) 19 | (dotimes (x xs) 20 | (with-pen(make-pen :fill (rgb (/ (1+ (sin-calc x)) 2) 21 | (/ (1+ (sin-calc (- x))) 2) 22 | 0.2) 23 | :stroke (gray 0.1)) 24 | (ngon 6 (* x (/ w xs)) (+ (/ h 2) (* (/ h 4) (sin-calc x))) r r) 25 | (ngon 6 (* x (/ w xs)) (+ (/ h 2) (* (/ h 4) (sin-calc (- x)))) r r) 26 | (ngon 6 (* x (/ w xs)) (+ (/ h 2) (* (/ h 4) (- (sin-calc (- x))))) r r) 27 | (ngon 6 (* x (/ w xs)) (+ (/ h 2) (* (/ h 4) (- (sin-calc x)))) r r)))))) 28 | -------------------------------------------------------------------------------- /examples/stars.lisp: -------------------------------------------------------------------------------- 1 | ;;;; stars.lisp 2 | 3 | (in-package #:sketch-examples) 4 | 5 | ;;; ____ _____ _ ____ ____ 6 | ;;; / ___|_ _|/ \ | _ \/ ___| 7 | ;;; \___ \ | | / _ \ | |_) \___ \ 8 | ;;; ___) || |/ ___ \| _ < ___) | 9 | ;;; |____/ |_/_/ \_\_| \_\____/ 10 | 11 | (defsketch stars 12 | ((bw nil) 13 | (stars (loop :for i :below 10 :collect (make-stars bw))) 14 | (positions (loop :for i :from 18 :downto 0 :by 2 :collect i)) 15 | (rotations (loop :repeat 10 :collect (cons 0 (- (random 0.2) 0.05))))) 16 | (background +black+) 17 | (dotimes (i (length stars)) 18 | (incf (elt positions i) 0.03) 19 | (incf (car (elt rotations i)) 20 | (cdr (elt rotations i))) 21 | (let ((zoom (get-zoom (elt positions i))) 22 | (rotation (car (elt rotations i)))) 23 | (with-current-matrix 24 | (with-pen (make-pen :fill (canvas-image (elt stars i))) 25 | (translate 200 200) 26 | (scale zoom) 27 | (rotate rotation) 28 | (rect -50 -50 100 100))))) 29 | (with-font (make-font :color +white+ :size 48 30 | :align :center) 31 | (text "s k e t c h" 200 160)) 32 | (when (>= (get-zoom (car positions)) 20) 33 | (setf (car positions) 0) 34 | (setf positions (rotate-list positions) 35 | rotations (rotate-list rotations)) 36 | (setf stars (rotate-list stars)))) 37 | 38 | (defun make-stars (bw) 39 | (let ((canvas (make-canvas 100 100))) 40 | (dotimes (i 20) 41 | (let ((x (random 100)) 42 | (y (random 100))) 43 | (unless (and (< 40 x 60) 44 | (< 40 y 60))) 45 | (canvas-paint canvas (if bw 46 | (gray-255 (+ 200 (random 55))) 47 | (if (< (random 3) 1) 48 | +magenta+ 49 | +cyan+)) 50 | x y))) 51 | (canvas-lock canvas) 52 | canvas)) 53 | 54 | (defun rotate-list (list) 55 | (let ((el (pop list))) 56 | (reverse (cons el (reverse list))))) 57 | 58 | (defun get-zoom (position) 59 | (exp (/ position 6))) 60 | -------------------------------------------------------------------------------- /res/sourcesans/LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright 2010, 2012, 2014 Adobe Systems Incorporated (http://www.adobe.com/), with Reserved Font Name 'Source'. All Rights Reserved. Source is a trademark of Adobe Systems Incorporated in the United States and/or other countries. 2 | 3 | This Font Software is licensed under the SIL Open Font License, Version 1.1. 4 | 5 | This license is copied below, and is also available with a FAQ at: http://scripts.sil.org/OFL 6 | 7 | 8 | ----------------------------------------------------------- 9 | SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 10 | ----------------------------------------------------------- 11 | 12 | PREAMBLE 13 | The goals of the Open Font License (OFL) are to stimulate worldwide 14 | development of collaborative font projects, to support the font creation 15 | efforts of academic and linguistic communities, and to provide a free and 16 | open framework in which fonts may be shared and improved in partnership 17 | with others. 18 | 19 | The OFL allows the licensed fonts to be used, studied, modified and 20 | redistributed freely as long as they are not sold by themselves. The 21 | fonts, including any derivative works, can be bundled, embedded, 22 | redistributed and/or sold with any software provided that any reserved 23 | names are not used by derivative works. The fonts and derivatives, 24 | however, cannot be released under any other type of license. The 25 | requirement for fonts to remain under this license does not apply 26 | to any document created using the fonts or their derivatives. 27 | 28 | DEFINITIONS 29 | "Font Software" refers to the set of files released by the Copyright 30 | Holder(s) under this license and clearly marked as such. This may 31 | include source files, build scripts and documentation. 32 | 33 | "Reserved Font Name" refers to any names specified as such after the 34 | copyright statement(s). 35 | 36 | "Original Version" refers to the collection of Font Software components as 37 | distributed by the Copyright Holder(s). 38 | 39 | "Modified Version" refers to any derivative made by adding to, deleting, 40 | or substituting -- in part or in whole -- any of the components of the 41 | Original Version, by changing formats or by porting the Font Software to a 42 | new environment. 43 | 44 | "Author" refers to any designer, engineer, programmer, technical 45 | writer or other person who contributed to the Font Software. 46 | 47 | PERMISSION & CONDITIONS 48 | Permission is hereby granted, free of charge, to any person obtaining 49 | a copy of the Font Software, to use, study, copy, merge, embed, modify, 50 | redistribute, and sell modified and unmodified copies of the Font 51 | Software, subject to the following conditions: 52 | 53 | 1) Neither the Font Software nor any of its individual components, 54 | in Original or Modified Versions, may be sold by itself. 55 | 56 | 2) Original or Modified Versions of the Font Software may be bundled, 57 | redistributed and/or sold with any software, provided that each copy 58 | contains the above copyright notice and this license. These can be 59 | included either as stand-alone text files, human-readable headers or 60 | in the appropriate machine-readable metadata fields within text or 61 | binary files as long as those fields can be easily viewed by the user. 62 | 63 | 3) No Modified Version of the Font Software may use the Reserved Font 64 | Name(s) unless explicit written permission is granted by the corresponding 65 | Copyright Holder. This restriction only applies to the primary font name as 66 | presented to the users. 67 | 68 | 4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font 69 | Software shall not be used to promote, endorse or advertise any 70 | Modified Version, except to acknowledge the contribution(s) of the 71 | Copyright Holder(s) and the Author(s) or with their explicit written 72 | permission. 73 | 74 | 5) The Font Software, modified or unmodified, in part or in whole, 75 | must be distributed entirely under this license, and must not be 76 | distributed under any other license. The requirement for fonts to 77 | remain under this license does not apply to any document created 78 | using the Font Software. 79 | 80 | TERMINATION 81 | This license becomes null and void if any of the above conditions are 82 | not met. 83 | 84 | DISCLAIMER 85 | THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 86 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF 87 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT 88 | OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE 89 | COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 90 | INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 91 | DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 92 | FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM 93 | OTHER DEALINGS IN THE FONT SOFTWARE. 94 | -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-Black.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-Black.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-BlackIt.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-BlackIt.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-Bold.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-Bold.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-BoldIt.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-BoldIt.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-ExtraLight.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-ExtraLight.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-ExtraLightIt.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-ExtraLightIt.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-It.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-It.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-Light.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-Light.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-LightIt.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-LightIt.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-Regular.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-Regular.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-Semibold.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-Semibold.otf -------------------------------------------------------------------------------- /res/sourcesans/SourceSansPro-SemiboldIt.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vydd/sketch/d427e6d296d2cd37b0c8df27cfe309da5f35ad7a/res/sourcesans/SourceSansPro-SemiboldIt.otf -------------------------------------------------------------------------------- /sketch-examples.asd: -------------------------------------------------------------------------------- 1 | ;;;; sketch-examples.asd 2 | 3 | (asdf:defsystem #:sketch-examples 4 | :description "Sketch examples" 5 | :author "Danilo Vidovic (vydd)" 6 | :license "MIT" 7 | :depends-on (#:alexandria 8 | #:sketch) 9 | :pathname "examples" 10 | :serial t 11 | :components ((:file "package") 12 | (:file "sinewave") 13 | (:file "life") 14 | (:file "brownian") 15 | (:file "hello-world") 16 | (:file "stars") 17 | (:file "indigo") 18 | )) 19 | -------------------------------------------------------------------------------- /sketch.asd: -------------------------------------------------------------------------------- 1 | ;;;; sketch.asd 2 | 3 | (asdf:defsystem #:sketch 4 | :description "Sketch is a Common Lisp framework for the creation of electronic art, computer graphics, visual design, game making and more. It is inspired by Processing and OpenFrameworks." 5 | :author "Danilo Vidovic (vydd)" 6 | :license "MIT" 7 | :depends-on (#:alexandria 8 | #:closer-mop 9 | #:glkit 10 | #:glu-tessellate 11 | #:mathkit 12 | #:md5 13 | #:sdl2 14 | #:cl-plus-c 15 | #:sdl2-image 16 | #:sdl2-ttf 17 | #:sdl2kit 18 | #:split-sequence 19 | #:static-vectors 20 | #:trivial-garbage 21 | #:zpng) 22 | :pathname "src" 23 | :serial t 24 | :components ((:file "package") 25 | (:file "math") 26 | (:file "utils") 27 | (:file "environment") 28 | (:file "resources") 29 | (:file "color") 30 | (:file "channels") 31 | (:file "shaders") 32 | (:file "pen") 33 | (:file "font") 34 | (:file "geometry") 35 | (:file "image") 36 | (:file "shapes") 37 | (:file "transforms") 38 | (:file "complex-transforms") 39 | (:file "drawing") 40 | (:file "bindings") 41 | (:file "sketch") 42 | (:file "entities") 43 | (:file "figures") 44 | (:file "controllers") 45 | (:file "canvas"))) 46 | -------------------------------------------------------------------------------- /src/bindings.lisp: -------------------------------------------------------------------------------- 1 | ;;;; bindings.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ ___ _ _ ____ ___ _ _ ____ ____ 6 | ;;; | __ )_ _| \ | | _ \_ _| \ | |/ ___/ ___| 7 | ;;; | _ \| || \| | | | | || \| | | _\___ \ 8 | ;;; | |_) | || |\ | |_| | || |\ | |_| |___) | 9 | ;;; |____/___|_| \_|____/___|_| \_|\____|____/ 10 | 11 | ;;; TODO: 12 | ;;; - Replace defaultp naming (hopefully the logic as well) 13 | ;;; with something less brittle. 14 | 15 | 16 | (defclass binding () 17 | ((name :initarg :name :accessor binding-name) 18 | (prefix :initarg :prefix :accessor binding-prefix) 19 | (package :initarg :package :accessor binding-package) 20 | (defaultp :initarg :defaultp :accessor binding-defaultp) 21 | (initform :initarg :initform :accessor binding-initform) 22 | (initarg :initarg :initarg :accessor binding-initarg) 23 | (accessor :initarg :accessor :accessor binding-accessor) 24 | (channelp :initarg :channelp :accessor binding-channelp) 25 | (channel-name :initarg :channel-name :accessor binding-channel-name))) 26 | 27 | (defun make-binding (name prefix 28 | &key 29 | (package nil) 30 | (defaultp nil) 31 | (initform nil) 32 | (initarg (alexandria:make-keyword name)) 33 | (accessor (make-accessor name prefix package)) 34 | (channel-name nil) 35 | (channelp (and channel-name t))) 36 | (make-instance 'binding :name name 37 | :prefix prefix 38 | :package package 39 | :defaultp defaultp 40 | :initform initform 41 | :initarg initarg 42 | :accessor accessor 43 | :channel-name channel-name 44 | :channelp channelp)) 45 | 46 | (defun make-accessor (name prefix package) 47 | (let ((symbol (alexandria:symbolicate prefix '#:- name))) 48 | (if package 49 | (intern (symbol-name symbol) (symbol-package prefix)) 50 | symbol))) 51 | 52 | (defun copy-binding (binding 53 | &key 54 | (name (binding-name binding)) 55 | (prefix (binding-prefix binding)) 56 | (initform (binding-initform binding)) 57 | (defaultp (binding-defaultp binding)) 58 | (initarg (binding-initarg binding)) 59 | (accessor (binding-accessor binding)) 60 | (channel-name (binding-channel-name binding)) 61 | (channelp (and channel-name t))) 62 | (make-instance 'binding 63 | :name name :prefix prefix :initform initform 64 | :defaultp defaultp :initarg initarg :accessor accessor 65 | :channelp channelp :channel-name channel-name)) 66 | 67 | (defun class-bindings (class &optional (mark-default-p t)) 68 | (loop for slot in (closer-mop:class-direct-slots class) 69 | for name = (closer-mop:slot-definition-name slot) 70 | for initform = (closer-mop:slot-definition-initform slot) 71 | unless (char= #\% (char (symbol-name name) 0)) 72 | collect (make-binding 73 | name 74 | (class-name class) 75 | :package (symbol-package (class-name class)) 76 | :defaultp mark-default-p 77 | :initform initform))) 78 | 79 | (defun parse-bindings (prefix binding-forms &optional existing-bindings) 80 | (loop for (name value . args) in (alexandria:ensure-list binding-forms) 81 | for channel-name = (when (channel-value-p value) (second value)) 82 | for existing = (car (member name existing-bindings :key #'binding-name)) 83 | when channel-name 84 | do (setf value (third value)) ; default channel value 85 | if existing 86 | collect (copy-binding 87 | existing 88 | :initform value 89 | :channel-name channel-name 90 | :defaultp nil) 91 | into created 92 | and collect existing into overriden 93 | else 94 | collect (apply #'make-binding (list* name prefix 95 | :initform value 96 | :channel-name channel-name 97 | args)) 98 | into created 99 | finally 100 | (let ((remaining-existing 101 | (remove-if (lambda (b) (member b overriden)) 102 | existing-bindings))) 103 | (return (append remaining-existing created))))) 104 | 105 | (defun channel-value-p (value) 106 | "If a VALUE is of form (IN CHANNEL-NAME DEFAULT-VALUE) 107 | it is recognized as a channel." 108 | (and (consp value) (eq 'in (car value)))) 109 | -------------------------------------------------------------------------------- /src/canvas.lisp: -------------------------------------------------------------------------------- 1 | ;;;; canvas.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ _ _ ___ ___ ____ 6 | ;;; / ___| / \ | \ | \ \ / / \ / ___| 7 | ;;; | | / _ \ | \| |\ \ / / _ \ \___ \ 8 | ;;; | |___ / ___ \| |\ | \ V / ___ \ ___) | 9 | ;;; \____/_/ \_|_| \_| \_/_/ \_|____/ 10 | 11 | 12 | (defclass canvas () 13 | ((width :initarg :width :reader canvas-width) 14 | (height :initarg :height :reader canvas-height) 15 | (%image :initform nil :accessor %canvas-image) 16 | (%vector :initform nil :accessor %canvas-vector) 17 | (%locked :initform nil :accessor %canvas-locked))) 18 | 19 | (defun make-canvas (width height) 20 | (let ((canvas (make-instance 'canvas :width width :height height))) 21 | (canvas-reset canvas) 22 | canvas)) 23 | 24 | (defmethod %canvas-vector-pointer ((canvas canvas)) 25 | (static-vectors:static-vector-pointer (%canvas-vector canvas))) 26 | 27 | (defmethod canvas-reset ((canvas canvas)) 28 | (setf (%canvas-vector canvas) 29 | (static-vectors:make-static-vector (* (canvas-width canvas) (canvas-height canvas) 4) :initial-element 0))) 30 | 31 | (defmethod canvas-paint ((canvas canvas) (color color) x y) 32 | (let ((ptr (%canvas-vector-pointer canvas)) 33 | (pos (+ (* x 4) (* y 4 (canvas-width canvas)))) 34 | (vec (color-bgra-255 color))) 35 | (dotimes (i 4) 36 | (setf (cffi:mem-aref ptr :uint8 (+ pos i)) (elt vec i))))) 37 | 38 | (defmethod canvas-image ((canvas canvas) 39 | &key (min-filter :linear) 40 | (mag-filter :linear) 41 | &allow-other-keys) 42 | (if (%canvas-locked canvas) 43 | (%canvas-image canvas) 44 | (make-image-from-surface 45 | (sdl2:create-rgb-surface-with-format-from 46 | (%canvas-vector-pointer canvas) 47 | (canvas-width canvas) 48 | (canvas-height canvas) 49 | 32 50 | (* 4 (canvas-width canvas)) 51 | :format sdl2:+pixelformat-argb8888+) 52 | :min-filter min-filter 53 | :mag-filter mag-filter))) 54 | 55 | (defmethod canvas-lock ((canvas canvas) 56 | &key (min-filter :linear) 57 | (mag-filter :linear) 58 | &allow-other-keys) 59 | (setf (%canvas-image canvas) (canvas-image canvas 60 | :min-filter min-filter 61 | :mag-filter mag-filter) 62 | (%canvas-locked canvas) t)) 63 | 64 | (defmethod canvas-unlock ((canvas canvas)) 65 | (setf (%canvas-locked canvas) nil)) 66 | 67 | (defmethod draw ((canvas canvas) 68 | &key (x 0) (y 0) width height mode 69 | (min-filter :linear) 70 | (mag-filter :linear) 71 | &allow-other-keys) 72 | "Draws a canvas with its top-left corner at co-ordinates X & Y. By default, 73 | uses the width and height that the canvas was created with, but these can be 74 | overwritten by parameters WIDTH and HEIGHT. 75 | 76 | MIN-FILTER and MAG-FILTER are used to determine pixel colours when the 77 | drawing area is smaller or larger, respectively, than the canvas. By default, 78 | the :LINEAR function is used. :NEAREST is also a common option. Note that, if 79 | CANVAS-LOCK is being used, then MIN-FILTER and MAG-FILTER should be passed 80 | there instead. 81 | 82 | See: https://registry.khronos.org/OpenGL-Refpages/gl4/html/glTexParameter.xhtml" 83 | (declare (ignore mode)) 84 | (draw (canvas-image canvas :min-filter min-filter :mag-filter mag-filter) 85 | :x x 86 | :y y 87 | :width (or width (canvas-width canvas)) 88 | :height (or height (canvas-height canvas)))) 89 | -------------------------------------------------------------------------------- /src/channels.lisp: -------------------------------------------------------------------------------- 1 | ;;;; channels.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ _ _ _ _ _ _ _ _____ _ ____ 6 | ;;; / ___| | | | / \ | \ | | \ | | ____| | / ___| 7 | ;;; | | | |_| | / _ \ | \| | \| | _| | | \___ \ 8 | ;;; | |___| _ |/ ___ \| |\ | |\ | |___| |___ ___) | 9 | ;;; \____|_| |_/_/ \_\_| \_|_| \_|_____|_____|____/ 10 | 11 | ;;; Channel interface 12 | 13 | (defparameter *channels* (make-hash-table)) 14 | 15 | (defun register-input (channel &optional initial (adapter #'identity)) 16 | (unless (assoc adapter (gethash channel *channels*)) 17 | (push (cons adapter initial) (gethash channel *channels*))) 18 | t) 19 | 20 | (defun in (channel &optional initial (adapter #'identity)) 21 | (register-input channel initial adapter) 22 | (let ((a (cdr (assoc adapter (gethash channel *channels*))))) 23 | (or a initial))) 24 | 25 | (defun out-1 (channel message) 26 | (register-input channel message #'identity) 27 | (mapcar (lambda (adapter-value-cons) 28 | (setf (cdr adapter-value-cons) 29 | (funcall (car adapter-value-cons) message))) 30 | (gethash channel *channels*)) 31 | (propagate channel)) 32 | 33 | (defun out (&rest channel-message) 34 | (mapcar (lambda (x) (out-1 (first x) (second x))) 35 | (group channel-message)) 36 | (values)) 37 | 38 | ;;; Channel propagation 39 | 40 | (defstruct propagation 41 | name 42 | inputs 43 | outputs 44 | function) 45 | 46 | (defparameter *propagations* (make-hash-table)) 47 | (defparameter *channel-propagations* (make-hash-table)) 48 | 49 | (defun propagate (channel) 50 | (mapcar (lambda (p) (funcall (propagation-function p))) 51 | (gethash channel *channel-propagations*))) 52 | 53 | (defun find-inputs-and-outputs (body) 54 | (let ((flat-body (alexandria:flatten body)) 55 | (inputs-and-outputs (list (list 'in) (list 'out))) 56 | (push-into nil)) 57 | (dolist (token flat-body) 58 | (alexandria:if-let ((io-cons (assoc push-into inputs-and-outputs))) 59 | (progn 60 | (when (not (member token (cdr io-cons))) 61 | (setf (cdr io-cons) (cons token (cdr io-cons)))) 62 | (setf push-into nil)) 63 | (setf push-into token))) 64 | inputs-and-outputs)) 65 | 66 | (defun extract-input-registration (body) 67 | (mapcar (lambda (in-form) (cadr in-form)) 68 | (remove-if #'atom (flatten body (lambda (x) (eql (car x) 'in)))))) 69 | 70 | (defun delete-channel-propagation (channel propagation) 71 | (setf (gethash channel *channel-propagations*) 72 | (remove-if (lambda (x) (eql x propagation)) 73 | (gethash channel *channel-propagations*)))) 74 | 75 | (defun update-propagation-data (name inputs outputs) 76 | (let ((propagation (gethash name *propagations*))) 77 | (if propagation 78 | (mapcar (lambda (channel) 79 | (delete-channel-propagation channel propagation)) 80 | (propagation-inputs propagation)) 81 | (setf propagation (make-propagation :name name) 82 | (gethash name *propagations*) propagation)) 83 | (setf (propagation-inputs propagation) inputs 84 | (propagation-outputs propagation) outputs) 85 | (mapcar (lambda (channel) 86 | (push propagation (gethash channel *channel-propagations*))) 87 | inputs))) 88 | 89 | (defun %define-channel-observer (name body) 90 | (let ((name (or name (gensym)))) 91 | (let* ((inputs-and-outputs (find-inputs-and-outputs body)) 92 | (inputs (cdr (assoc 'in inputs-and-outputs))) 93 | (outputs (cdr (assoc 'out inputs-and-outputs))) 94 | (input-registrations (extract-input-registration body))) 95 | (update-propagation-data name inputs outputs) 96 | (mapcar #'register-input input-registrations) 97 | (setf (propagation-function (gethash name *propagations*)) 98 | (eval `(lambda () ,@body))) 99 | (when outputs 100 | (mapcar #'propagate inputs))))) 101 | 102 | (defmacro define-named-channel-observer (name &body body) 103 | (%define-channel-observer name body) 104 | nil) 105 | 106 | (defmacro define-channel-observer (&body body) 107 | (%define-channel-observer nil body) 108 | nil) 109 | 110 | ;;; Utility functions 111 | 112 | (defun reset-channel (channel) 113 | (remhash channel *channels*) 114 | (remhash channel *channel-propagations*) 115 | (maphash (lambda (name propagation) 116 | (declare (ignore name)) 117 | (setf (propagation-inputs propagation) 118 | (remove-if (lambda (x) (eql x channel)) 119 | (propagation-inputs propagation)) 120 | (propagation-outputs propagation) 121 | (remove-if (lambda (x) (eql x channel)) 122 | (propagation-outputs propagation)))) 123 | *propagations*) 124 | (values)) 125 | 126 | (defun reset-all-channels () 127 | (setf *channels* (make-hash-table) 128 | *propagations* (make-hash-table) 129 | *channel-propagations* (make-hash-table)) 130 | (values)) 131 | -------------------------------------------------------------------------------- /src/color.lisp: -------------------------------------------------------------------------------- 1 | ;;;; color.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ ___ _ ___ ____ 6 | ;;; / ___/ _ \| | / _ \| _ \ 7 | ;;; | | | | | | | | | | | |_) | 8 | ;;; | |__| |_| | |__| |_| | _ < 9 | ;;; \____\___/|_____\___/|_| \_\ 10 | 11 | ;;; General 12 | 13 | (defclass color (resource) 14 | ((red :initform 0.0 :accessor color-red :initarg :red) 15 | (green :initform 0.0 :accessor color-green :initarg :green) 16 | (blue :initform 0.0 :accessor color-blue :initarg :blue) 17 | (hue :initform 0.0 :accessor color-hue :initarg :hue) 18 | (saturation :initform 0.0 :accessor color-saturation :initarg :saturation) 19 | (brightness :initform 0.0 :accessor color-brightness :initarg :brightness) 20 | (alpha :initform 1.0 :accessor color-alpha :initarg :alpha))) 21 | 22 | (defun rgb-to-hsb (r g b) 23 | (let* ((c-max (max r g b)) 24 | (c-min (min r g b)) 25 | (delta (- c-max c-min)) 26 | (hue (* 60 (cond ((= delta 0) 0) 27 | ((= c-max r) (mod (/ (- g b) delta) 6)) 28 | ((= c-max g) (+ (/ (- b r) delta) 2)) 29 | ((= c-max b) (+ (/ (- r g) delta) 4)) 30 | (t 0)))) 31 | (saturation (if (zerop c-max) 32 | 0 33 | (/ delta c-max))) 34 | (brightness c-max)) 35 | (list (/ hue 360) saturation brightness))) 36 | 37 | (defun hsb-to-rgb (h s b) 38 | (let* ((h (mod (* h 360) 360)) 39 | (c (* b s)) 40 | (x (* c (- 1 (abs (- (mod (/ h 60) 2) 1))))) 41 | (m (- b c))) 42 | (mapcar (lambda (x) (+ m x)) 43 | (aref `#((,c ,x 0) (,x ,c 0) (0 ,c ,x) 44 | (0 ,x ,c) (,x 0 ,c) (,c 0 ,x)) 45 | (floor (/ h 60)))))) 46 | 47 | (defun update-rgb (color) 48 | (with-slots (red green blue hue saturation brightness) color 49 | (destructuring-bind (r g b) (hsb-to-rgb hue saturation brightness) 50 | (setf red r 51 | green g 52 | blue b)))) 53 | 54 | (defun update-hsb (color) 55 | (with-slots (red green blue hue saturation brightness) color 56 | (destructuring-bind (h s b) (rgb-to-hsb red green blue) 57 | (setf hue h 58 | saturation s 59 | brightness b)))) 60 | 61 | (defmacro add-updater-to-accessor (accessor updater) 62 | `(defmethod (setf ,accessor) :after (value color) 63 | (,updater color))) 64 | 65 | (add-updater-to-accessor color-red update-hsb) 66 | (add-updater-to-accessor color-green update-hsb) 67 | (add-updater-to-accessor color-blue update-hsb) 68 | (add-updater-to-accessor color-hue update-rgb) 69 | (add-updater-to-accessor color-saturation update-rgb) 70 | (add-updater-to-accessor color-brightness update-rgb) 71 | 72 | ;;; Constructors 73 | 74 | (defun rgb (red green blue &optional (alpha 1.0)) 75 | (destructuring-bind (red green blue alpha) 76 | (mapcar #'clamp-1 (list red green blue alpha)) 77 | (let ((hsb (rgb-to-hsb red green blue))) 78 | (make-instance 'color :red red :green green :blue blue :alpha alpha 79 | :hue (elt hsb 0) :saturation (elt hsb 1) :brightness (elt hsb 2))))) 80 | 81 | (defun hsb (hue saturation brightness &optional (alpha 1.0)) 82 | (destructuring-bind (hue saturation brightness alpha) 83 | (mapcar #'clamp-1 (list hue saturation brightness alpha)) 84 | (let ((rgb (hsb-to-rgb hue saturation brightness))) 85 | (make-instance 'color :hue hue :saturation saturation :brightness brightness :alpha alpha 86 | :red (elt rgb 0) :green (elt rgb 1) :blue (elt rgb 2))))) 87 | 88 | (defun gray (amount &optional (alpha 1.0)) 89 | (rgb amount amount amount alpha)) 90 | 91 | (defun rgb-255 (red green blue &optional (alpha 255)) 92 | (rgb (/ red 255) (/ green 255) (/ blue 255) (/ alpha 255))) 93 | 94 | (defun hsb-360 (hue saturation brightness &optional (alpha 255)) 95 | (hsb (/ hue 360) (/ saturation 100) (/ brightness 100) (/ alpha 255))) 96 | 97 | (defun gray-255 (amount &optional (alpha 255)) 98 | (gray (/ amount 255) (/ alpha 255))) 99 | 100 | (defun hex-to-color (string) 101 | (let ((string (string-left-trim "#" string))) 102 | (destructuring-bind (r g b &optional (a 1.0)) 103 | (let* ((bits (case (length string) 104 | ((3 4) 4) 105 | ((6 8) 8) 106 | (t (error "~a is not a valid hex color." string)))) 107 | (groups (group-bits (parse-integer string :radix 16 :junk-allowed t) 108 | bits))) 109 | (pad-list (mapcar (lambda (x) (/ x (if (= bits 4) 15 255))) groups) 110 | 0 111 | (if (= 4 bits) 112 | (length string) 113 | (/ (length string) 2)))) 114 | (rgb r g b a)))) 115 | 116 | (defun color-rgb (color) 117 | (list (color-red color) 118 | (color-green color) 119 | (color-blue color))) 120 | 121 | (defun color-bgr (color) 122 | (list (color-blue color) 123 | (color-green color) 124 | (color-red color))) 125 | 126 | (defun color-rgba (color) 127 | (list (color-red color) 128 | (color-green color) 129 | (color-blue color) 130 | (color-alpha color))) 131 | 132 | (defun color-bgra (color) 133 | (list (color-blue color) 134 | (color-green color) 135 | (color-red color) 136 | (color-alpha color))) 137 | 138 | (defun color-rgba-255 (color) 139 | (mapcar (lambda (x) (coerce (truncate (* 255 x)) 'unsigned-byte)) 140 | (color-rgba color))) 141 | 142 | (defun color-bgra-255 (color) 143 | (mapcar (lambda (x) (coerce (truncate (* 255 x)) 'unsigned-byte)) 144 | (color-bgra color))) 145 | 146 | (defun color-hsba (color) 147 | (list (color-hue color) 148 | (color-saturation color) 149 | (color-brightness color) 150 | (color-alpha color))) 151 | 152 | (defun color-vector (color) 153 | (apply #'vector (mapcar #'coerce-float (color-rgba color)))) 154 | 155 | (defun color-vector-255 (color) 156 | (apply #'vector (color-rgba-255 color))) 157 | 158 | ;;; Generators 159 | 160 | (defun lerp-color (start-color end-color amount &key (mode :hsb)) 161 | (let ((a (clamp-1 amount))) 162 | (flet ((norm (field) 163 | (normalize a 0.0 1.0 164 | :out-low (slot-value start-color field) 165 | :out-high (slot-value end-color field)))) 166 | (if (eq mode :hsb) 167 | (apply #'hsb (mapcar #'norm '(hue saturation brightness alpha))) 168 | (apply #'rgb (mapcar #'norm '(red green blue alpha))))))) 169 | 170 | (defun random-color (&optional (alpha 1.0)) 171 | (rgb (random 1.0) (random 1.0) (random 1.0) alpha)) 172 | 173 | (defun hash-color (n &optional (alpha 1.0)) 174 | (let* ((grp (group-bits n)) 175 | (arr (make-array (length grp) 176 | :element-type '(unsigned-byte 8) 177 | :initial-contents grp)) 178 | (seq (md5:md5sum-sequence arr)) 179 | (hash (loop for i across seq sum i))) 180 | (hsb-360 (mod (+ (* 144 (mod n 20)) (mod hash 60)) 360) 181 | (alexandria:clamp (+ 25 (* 25 (mod hash 4)) (mod hash 25)) 0 100) 182 | (alexandria:clamp (+ 25 (* 25 (mod n 4)) (mod hash 20)) 0 100) 183 | (* 255 alpha)))) 184 | 185 | ;;; Filters 186 | 187 | (defun color-filter-grayscale (color &optional (mode :luminosity)) 188 | (case mode 189 | ((:lightness 1) (gray (/ (+ (apply #'max (color-rgb color)) 190 | (apply #'min (color-rgb color)))) 191 | (color-alpha color))) 192 | ((:average 2) (gray (/ (apply #'+ (color-rgb color)) 3) 193 | (color-alpha color))) 194 | (t (gray (+ (* 0.21 (color-red color)) 195 | (* 0.72 (color-green color)) 196 | (* 0.07 (color-blue color))) 197 | (color-alpha color))))) 198 | 199 | (defun color-filter-invert (color) 200 | (hsb (let ((h (- (color-hue color) 0.5))) 201 | (if (plusp h) 202 | h 203 | (+ 1 h))) 204 | (color-saturation color) 205 | (color-brightness color) 206 | (color-alpha color))) 207 | 208 | (defun color-filter-rotate (color) 209 | (rgb (color-green color) 210 | (color-blue color) 211 | (color-red color))) 212 | 213 | (defun color-filter-hsb (color &key (hue 0.0) (saturation 0.0) (brightness 0.0)) 214 | (let ((hue (clamp-1 (+ hue (color-hue color)))) 215 | (saturation (clamp-1 (+ saturation (color-brightness color)))) 216 | (brightness (clamp-1 (+ brightness (color-brightness color)))) 217 | (alpha (color-alpha color))) 218 | (destructuring-bind (red green blue) (hsb-to-rgb hue saturation brightness) 219 | (make-instance 'color 220 | :red red :green green :blue blue :alpha alpha 221 | :hue hue :saturation saturation :brightness brightness)))) 222 | 223 | ;;; Predefined colors 224 | 225 | (defparameter +red+ (rgb 1 0 0)) 226 | (defparameter +green+ (rgb 0 1 0)) 227 | (defparameter +blue+ (rgb 0 0 1)) 228 | (defparameter +yellow+ (rgb 1 1 0)) 229 | (defparameter +magenta+ (rgb 1 0 1)) 230 | (defparameter +cyan+ (rgb 0 1 1)) 231 | (defparameter +orange+ (rgb 1.0 0.5 0.0)) 232 | (defparameter +white+ (gray 1)) 233 | (defparameter +black+ (gray 0)) 234 | (defparameter +gray+ (gray 0.5)) 235 | (defparameter +indigo+ (hex-to-color "#4b0082")) 236 | -------------------------------------------------------------------------------- /src/complex-transforms.lisp: -------------------------------------------------------------------------------- 1 | ;;;; complex-transforms.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; FIT, WITH-FIT 6 | ;;; Modes were taken from GTK, see https://docs.gtk.org/gtk4/enum.ContentFit.html 7 | (defun fit (to-width to-height from-width from-height &key (mode :contain)) 8 | (check-type mode (member :contain :cover :scale-down :fill)) 9 | (ecase mode 10 | ((:contain :cover :scale-down) 11 | (flet ((%fit-scale (scale) 12 | (let ((x-shift (/ (- from-width 13 | (* to-width scale)) 14 | 2)) 15 | (y-shift (/ (- from-height 16 | (* to-height scale)) 17 | 2))) 18 | (translate x-shift y-shift) 19 | (scale scale)))) 20 | (%fit-scale 21 | (ecase mode 22 | (:contain (min (/ from-width to-width) 23 | (/ from-height to-height))) 24 | (:cover (max (/ from-width to-width) 25 | (/ from-height to-height))) 26 | (:scale-down (min (/ from-width to-width) 27 | (/ from-height to-height) 28 | 1)))))) 29 | (:fill 30 | (scale (/ from-width to-width) 31 | (/ from-height to-height))))) 32 | 33 | (defmacro with-fit ((to-width to-height from-width from-height &key (mode :contain)) 34 | &body body) 35 | `(with-current-matrix 36 | (fit ,to-width ,to-height ,from-width ,from-height :mode ,mode) 37 | ,@body)) 38 | -------------------------------------------------------------------------------- /src/controllers.lisp: -------------------------------------------------------------------------------- 1 | ;;;; controllers.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ ___ _ _ _____ ____ ___ _ _ _____ ____ ____ 6 | ;;; / ___/ _ \| \ | |_ _| _ \ / _ \| | | | | ____| _ \/ ___| 7 | ;;; | | | | | | \| | | | | |_) | | | | | | | | _| | |_) \___ \ 8 | ;;; | |__| |_| | |\ | | | | _ <| |_| | |___| |___| |___| _ < ___) | 9 | ;;; \____\___/|_| \_| |_| |_| \_\\___/|_____|_____|_____|_| \_\____/ 10 | 11 | ;;; Mouse 12 | 13 | (defparameter *current-entity* nil) 14 | 15 | (defun propagate-to-entity (sketch f x y &rest other-args) 16 | (loop 17 | for entity being the hash-key of (sketch-%entities sketch) 18 | for (im iw ih) being the hash-value of (sketch-%entities sketch) 19 | for (ix iy) = (transform-vertex (list x y) im) 20 | when (and (< 0 ix iw) (< 0 iy ih)) 21 | ;; x & y arguments always come last. 22 | do (apply f entity (append other-args (list ix iy))))) 23 | 24 | (defmacro def-xy-event-method (method-name args) 25 | "Defines a method for an event, as well as an :around method 26 | that sets the sketch environment and propagates the event to entities. 27 | x & y are assumed to come last in the argument list." 28 | `(progn 29 | (defmethod ,method-name (instance ,@args)) 30 | (defmethod ,method-name :around ((*sketch* sketch) ,@args) 31 | (with-sketch (*sketch*) 32 | (let ((*draw-mode* nil)) 33 | (propagate-to-entity *sketch* #',method-name x y 34 | ,@(remove-if (lambda (arg) (member arg '(x y))) 35 | args)) 36 | (call-next-method)))))) 37 | 38 | (def-xy-event-method on-click (x y)) 39 | (def-xy-event-method on-middle-click (x y)) 40 | (def-xy-event-method on-right-click (x y)) 41 | (def-xy-event-method on-mouse-button (button state x y)) 42 | (def-xy-event-method on-mouse-left (state x y)) 43 | (def-xy-event-method on-mouse-middle (state x y)) 44 | (def-xy-event-method on-mouse-right (state x y)) 45 | (def-xy-event-method on-mouse-left-up (x y)) 46 | (def-xy-event-method on-mouse-left-down (x y)) 47 | (def-xy-event-method on-mouse-middle-up (x y)) 48 | (def-xy-event-method on-mouse-middle-down (x y)) 49 | (def-xy-event-method on-mouse-right-up (x y)) 50 | (def-xy-event-method on-mouse-right-down (x y)) 51 | (def-xy-event-method on-hover (x y)) 52 | (defmethod on-enter (instance)) 53 | (defmethod on-leave (instance)) 54 | 55 | (defmethod on-hover :around ((entity entity) ix iy) 56 | (let ((*draw-mode* nil)) 57 | (unless (eql *current-entity* entity) 58 | (on-leave *current-entity*) 59 | (setf *current-entity* entity) 60 | (on-enter entity)) 61 | (call-next-method))) 62 | 63 | (defmethod kit.sdl2:mousebutton-event ((instance sketch-window) state timestamp button x y) 64 | ;; For backward compatibility. 65 | (kit.sdl2:mousebutton-event (%sketch instance) state timestamp button x y) 66 | (on-mouse-button (%sketch instance) 67 | (translate-sdl2-button button) 68 | (translate-sdl2-button-state state) 69 | x 70 | y)) 71 | 72 | (defun translate-sdl2-button (button) 73 | (case button 74 | (1 :left) 75 | (2 :middle) 76 | (3 :right) 77 | (t button))) 78 | 79 | (defun translate-sdl2-button-state (state) 80 | (case state 81 | (:mousebuttondown :down) 82 | (:mousebuttonup :up) 83 | (t state))) 84 | 85 | (defmethod on-mouse-button :after ((instance sketch) button state x y) 86 | (case button 87 | (:left (on-mouse-left instance state x y)) 88 | (:middle (on-mouse-middle instance state x y)) 89 | (:right (on-mouse-right instance state x y)))) 90 | 91 | (defmacro def-on-mouse (button-name) 92 | (let ((method-name (alexandria:symbolicate 'on-mouse- button-name))) 93 | `(defmethod ,method-name :after ((instance sketch) state x y) 94 | (case state 95 | (:down (,(alexandria:symbolicate method-name '-down) instance x y)) 96 | (:up (,(alexandria:symbolicate method-name '-up) instance x y)))))) 97 | 98 | (def-on-mouse left) 99 | (def-on-mouse middle) 100 | (def-on-mouse right) 101 | 102 | (defmethod on-mouse-left-up :after ((instance sketch) x y) 103 | (on-click instance x y)) 104 | (defmethod on-mouse-middle-up :after ((instance sketch) x y) 105 | (on-middle-click instance x y)) 106 | (defmethod on-mouse-right-up :after ((instance sketch) x y) 107 | (on-right-click instance x y)) 108 | 109 | (defmethod kit.sdl2:mousemotion-event ((instance sketch-window) timestamp button-mask x y xrel yrel) 110 | ;; For backward compatibility. 111 | (kit.sdl2:mousemotion-event (%sketch instance) timestamp button-mask x y xrel yrel) 112 | (with-slots ((sketch %sketch)) instance 113 | (on-hover sketch x y) 114 | (unless 115 | (loop for entity being the hash-key of (sketch-%entities sketch) 116 | for (im iw ih) being the hash-value of (sketch-%entities sketch) 117 | for (ix iy) = (transform-vertex (list x y) im) 118 | when (and (< 0 ix iw) (< 0 iy ih)) 119 | do (on-hover entity ix iy) 120 | (return t)) 121 | (when *current-entity* 122 | (on-leave *current-entity*) 123 | (setf *current-entity* nil))))) 124 | 125 | (defmethod kit.sdl2:mousemotion-event :after ((instance sketch-window) 126 | timestamp button-mask x y xrel yrel) 127 | (out :mouse (cons x y) 128 | :mouse-x x 129 | :mouse-y y 130 | :mouse-rel (cons xrel yrel) 131 | :mouse-xrel xrel 132 | :mouse-yrel yrel)) 133 | 134 | (defmethod kit.sdl2:mousewheel-event :after ((instance sketch-window) 135 | timestamp x y) 136 | (out :mouse-wheel (cons x y) 137 | :mouse-wheel-x x 138 | :mouse-wheel-y y)) 139 | 140 | (defmethod kit.sdl2:mousebutton-event :after ((instance sketch-window) 141 | state timestamp button x y) 142 | (with-slots (%env) (%sketch instance) 143 | (when (env-red-screen %env) 144 | (when (eq state :mousebuttonup) 145 | (setf (env-debug-key-pressed %env) t))))) 146 | 147 | ;;; Keyboard 148 | 149 | (defmethod on-text (instance text)) 150 | (defmethod on-key (instance key state)) 151 | 152 | (defmethod on-text :around ((*sketch* sketch) text) 153 | (with-sketch (*sketch*) 154 | (let ((*draw-mode* nil)) 155 | (call-next-method)))) 156 | 157 | (defmethod on-key :around ((*sketch* sketch) key state) 158 | (with-sketch (*sketch*) 159 | (let ((*draw-mode* nil)) 160 | (call-next-method)))) 161 | 162 | (defmethod kit.sdl2:textinput-event :after ((instance sketch-window) timestamp text) 163 | (on-text (%sketch instance) text)) 164 | 165 | (defmethod kit.sdl2:keyboard-event :after ((instance sketch-window) state timestamp repeat-p keysym) 166 | (when (not repeat-p) 167 | (on-key (%sketch instance) 168 | (without-sdl2-scancode-prefix keysym) 169 | (translate-sdl2-key-state state)))) 170 | 171 | (defun translate-sdl2-key-state (state) 172 | (case state 173 | (:keydown :down) 174 | (:keyup :up) 175 | (t state))) 176 | -------------------------------------------------------------------------------- /src/drawing.lisp: -------------------------------------------------------------------------------- 1 | ;;;; drawing.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ ____ ___ _____ _ _ ____ 6 | ;;; | _ \| _ \ / \ \ / /_ _| \ | |/ ___| 7 | ;;; | | | | |_) | / _ \ \ /\ / / | || \| | | _ 8 | ;;; | |_| | _ < / ___ \ V V / | || |\ | |_| | 9 | ;;; |____/|_| \_\/_/ \_\_/\_/ |___|_| \_|\____| 10 | ;;; 11 | ;;; http://onrendering.blogspot.com/2011/10/buffer-object-streaming-in-opengl.html 12 | ;;; http://www.java-gaming.org/index.php?topic=32169.0 13 | 14 | (kit.gl.vao:defvao sketch-vao () 15 | (:interleave () 16 | (vertex :float 2) 17 | (texcoord :float 2) 18 | (color :unsigned-byte 4 :out-type :float))) 19 | 20 | (defparameter *buffer-size* (expt 2 17)) 21 | (defparameter *vertex-attributes* 5) 22 | (defparameter *bytes-per-vertex* (+ (* 4 *vertex-attributes*))) 23 | (defparameter +access-mode+ 24 | (cffi:foreign-bitfield-value '%gl:BufferAccessMask 25 | '(:map-write :map-unsynchronized))) 26 | 27 | (defparameter *draw-mode* :gpu) 28 | (defparameter *draw-sequence* nil) 29 | 30 | (defparameter *uv-rect* nil) 31 | 32 | (defmacro with-uv-rect (rect &body body) 33 | `(let ((*uv-rect* ,rect)) 34 | ,@body)) 35 | 36 | (defun start-draw () 37 | (%gl:bind-buffer :array-buffer (aref (slot-value (env-vao *env*) 'kit.gl.vao::vbos) 0)) 38 | (%gl:buffer-data :array-buffer *buffer-size* (cffi:null-pointer) :stream-draw) 39 | (setf (env-buffer-position *env*) 0) 40 | (kit.gl.vao:vao-bind (env-vao *env*))) 41 | 42 | (defun end-draw () 43 | (%gl:bind-buffer :array-buffer 0) 44 | (kit.gl.vao:vao-unbind)) 45 | 46 | (defun shader-color-texture-values (res) 47 | (typecase res 48 | (color (values (or (color-vector-255 res) (env-white-color-vector *env*)) 49 | (env-white-pixel-texture *env*))) 50 | (cropped-image (values (env-white-color-vector *env*) 51 | (or (image-texture res) (env-white-pixel-texture *env*)) 52 | (cropped-image-uv-rect res))) 53 | (image (values (env-white-color-vector *env*) 54 | (or (image-texture res) (env-white-pixel-texture *env*)))))) 55 | 56 | (defun draw-shape (primitive fill-vertices stroke-vertices) 57 | (when (and fill-vertices (pen-fill (env-pen *env*))) 58 | (multiple-value-bind (shader-color shader-texture uv-rect) 59 | (shader-color-texture-values (pen-fill (env-pen *env*))) 60 | (with-uv-rect uv-rect 61 | (push-vertices fill-vertices 62 | shader-color 63 | shader-texture 64 | primitive 65 | *draw-mode*)))) 66 | (when (and stroke-vertices (pen-stroke (env-pen *env*))) 67 | (multiple-value-bind (shader-color shader-texture uv-rect) 68 | (shader-color-texture-values (pen-stroke (env-pen *env*))) 69 | (with-uv-rect uv-rect 70 | (let* ((weight (or (pen-weight (env-pen *env*)) 1)) 71 | (mixed (mix-lists stroke-vertices 72 | (grow-polygon stroke-vertices weight)))) 73 | (push-vertices (append mixed (list (first mixed) (second mixed))) 74 | shader-color 75 | shader-texture 76 | :triangle-strip 77 | *draw-mode*)))))) 78 | 79 | (defmethod push-vertices (vertices color texture primitive (draw-mode (eql :gpu))) 80 | (kit.gl.shader:uniform-matrix (env-programs *env*) :model-m 4 81 | (vector (env-model-matrix *env*))) 82 | (gl:bind-texture :texture-2d texture) 83 | (symbol-macrolet ((position (env-buffer-position *env*))) 84 | (when (> (* *bytes-per-vertex* (+ position (length vertices))) *buffer-size*) 85 | (start-draw)) 86 | (let ((buffer-pointer (%gl:map-buffer-range :array-buffer 87 | (* position *bytes-per-vertex*) 88 | (* (length vertices) *bytes-per-vertex*) 89 | +access-mode+))) 90 | (fill-buffer buffer-pointer vertices color) 91 | (%gl:unmap-buffer :array-buffer) 92 | (%gl:draw-arrays primitive position (length vertices)) 93 | (setf position (+ position (length vertices)))))) 94 | 95 | (defmethod push-vertices (vertices color texture primitive (draw-mode (eql :figure))) 96 | (let* ((vertices (mapcar (lambda (v) (transform-vertex v (env-model-matrix *env*))) 97 | vertices)) 98 | (buffer (static-vectors:make-static-vector 99 | (* *bytes-per-vertex* (length vertices)) 100 | :element-type '(unsigned-byte 8))) 101 | (buffer-pointer (static-vectors:static-vector-pointer buffer))) 102 | (fill-buffer buffer-pointer vertices color) 103 | (push (list :primitive primitive 104 | :pointer buffer-pointer 105 | :length (length vertices)) 106 | *draw-sequence*))) 107 | 108 | (defmethod push-vertices (vertices color texture primitive (draw-mode null)) 109 | ;; TODO: Drawing in event handlers could be useful with COPY-PIXELS set to to T. 110 | (warn "Can't draw from current context (e.g. an event handler).")) 111 | 112 | (defun fit-uv-to-rect (uv) 113 | (if *uv-rect* 114 | (destructuring-bind (u-in v-in) uv 115 | (destructuring-bind (u1 v1 u-range v-range) *uv-rect* 116 | (list (+ u1 (* u-range u-in)) 117 | (+ v1 (* v-range v-in))))) 118 | uv)) 119 | 120 | (defun fill-buffer (buffer-pointer vertices color) 121 | (loop 122 | for idx from 0 by *vertex-attributes* 123 | for (x y) in vertices 124 | for (tx ty) in (mapcar #'fit-uv-to-rect (normalize-to-bounding-box vertices)) 125 | do (setf (cffi:mem-aref buffer-pointer :float idx) (coerce-float x) 126 | (cffi:mem-aref buffer-pointer :float (+ idx 1)) (coerce-float y) 127 | (cffi:mem-aref buffer-pointer :float (+ idx 2)) (coerce-float tx) 128 | (cffi:mem-aref buffer-pointer :float (+ idx 3)) (coerce-float (* ty (env-y-axis-sgn *env*))) 129 | (cffi:mem-aref buffer-pointer :uint8 (* 4 (+ idx 4))) (aref color 0) 130 | (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 1)) (aref color 1) 131 | (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 2)) (aref color 2) 132 | (cffi:mem-aref buffer-pointer :uint8 (+ (* 4 (+ idx 4)) 3)) (aref color 3)))) 133 | -------------------------------------------------------------------------------- /src/entities.lisp: -------------------------------------------------------------------------------- 1 | ;;;; entities.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; _____ _ _ _____ ___ _____ ___ _____ ____ 6 | ;;; | ____| \ | |_ _|_ _|_ _|_ _| ____/ ___| 7 | ;;; | _| | \| | | | | | | | | || _| \___ \ 8 | ;;; | |___| |\ | | | | | | | | || |___ ___) | 9 | ;;; |_____|_| \_| |_| |___| |_| |___|_____|____/ 10 | ;;; 11 | 12 | ;;; TODO: 13 | ;;; - Better code reuse with sketch.lisp 14 | 15 | (defparameter *entity* nil 16 | "The current entity.") 17 | 18 | (defclass entity () 19 | ((width :initform 100 :accessor entity-width :initarg :width) 20 | (height :initform 100 :accessor entity-height :initarg :height))) 21 | 22 | (defmethod register-entity ((sketch sketch) (entity entity) box) 23 | (setf (gethash entity (sketch-%entities sketch)) 24 | ;; TODO: sb-cga shouldn't be used directly from here. 25 | (cons (sb-cga:inverse-matrix (env-model-matrix (sketch-%env sketch))) box))) 26 | 27 | (defmethod initialize-instance :after ((instance entity) &rest initargs &key &allow-other-keys) 28 | (apply #'prepare instance initargs)) 29 | 30 | (defmethod update-instance-for-redefined-class :after 31 | ((instance entity) added-slots discarded-slots property-list &rest initargs) 32 | (declare (ignore added-slots discarded-slots property-list)) 33 | (apply #'prepare instance initargs)) 34 | 35 | (defun define-entity-defclass (name bindings) 36 | `(defclass ,name (entity) 37 | (,@(loop for b in bindings 38 | unless (eq 'entity (binding-prefix b)) 39 | collect `(,(binding-name b) 40 | :initarg ,(binding-initarg b) 41 | :accessor ,(binding-accessor b) 42 | ,@(when (binding-channelp b) '(:allocation :class))))))) 43 | 44 | (defun define-entity-channel-observers (entity-name bindings) 45 | (loop for b in bindings 46 | when (binding-channelp b) 47 | collect `(define-channel-observer 48 | (setf (,(binding-accessor b) (default-entity-instance ',entity-name)) 49 | (in ,(binding-channel-name b) 50 | ,(binding-initform b)))))) 51 | 52 | (defun define-entity-draw-method (name bindings body) 53 | `(defmethod draw ((*entity* ,name) 54 | &key (x 0) (y 0) (width (entity-width *entity*)) (height (entity-height *entity*)) mode 55 | &allow-other-keys) 56 | (declare (ignore mode)) 57 | (let ((from-width width) 58 | (from-height height)) 59 | (with-accessors (,@(loop for b in bindings 60 | collect `(,(binding-name b) ,(binding-accessor b)))) 61 | *entity* 62 | (with-translate (x y) 63 | (with-fit (width height from-width from-height :mode :contain) 64 | (register-entity *sketch* *entity* (list width height)) 65 | ,@body)))))) 66 | 67 | (defun define-entity-prepare-method (name bindings) 68 | `(defmethod prepare ((*entity* ,name) 69 | &key ,@(loop for b in bindings 70 | collect `((,(binding-initarg b) ,(binding-name b)) 71 | ,(if (binding-defaultp b) 72 | `(,(binding-accessor b) *entity*) 73 | (binding-initform b)))) 74 | &allow-other-keys) 75 | (setf ,@(loop for b in bindings 76 | collect `(,(binding-accessor b) *entity*) 77 | collect (binding-name b))))) 78 | 79 | (defmacro defentity (entity-name binding-forms &body body) 80 | (let ((bindings (parse-bindings entity-name binding-forms 81 | (class-bindings (find-class 'entity))))) 82 | `(progn 83 | ,(define-entity-defclass entity-name bindings) 84 | (let ((saved nil)) 85 | (defmethod default-entity-instance ((instance (eql ',entity-name))) 86 | (unless saved 87 | (setf saved (make-instance ',entity-name))) 88 | saved)) 89 | ,(define-entity-prepare-method entity-name bindings) 90 | ,(define-entity-draw-method entity-name bindings body) 91 | 92 | ,@(define-entity-channel-observers entity-name bindings) 93 | 94 | (make-instances-obsolete ',entity-name) 95 | (find-class ',entity-name)))) 96 | -------------------------------------------------------------------------------- /src/environment.lisp: -------------------------------------------------------------------------------- 1 | ;;;; environment.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; _____ _ ___ _____ ____ ___ _ _ __ __ _____ _ _ _____ 6 | ;;; | ____| \ | \ \ / /_ _| _ \ / _ \| \ | | \/ | ____| \ | |_ _| 7 | ;;; | _| | \| |\ \ / / | || |_) | | | | \| | |\/| | _| | \| | | | 8 | ;;; | |___| |\ | \ V / | || _ <| |_| | |\ | | | | |___| |\ | | | 9 | ;;; |_____|_| \_| \_/ |___|_| \_\\___/|_| \_|_| |_|_____|_| \_| |_| 10 | 11 | (defstruct env 12 | ;; Drawing 13 | (pen nil) 14 | (programs nil) 15 | (model-matrix (sb-cga:identity-matrix)) ; TODO: sb-cga shouldn't be used directly from here 16 | (view-matrix nil) 17 | (matrix-stack nil) 18 | (y-axis-sgn +1) 19 | (vao nil) 20 | (buffer-position 0) 21 | ;; Typography 22 | (font nil) 23 | ;; Textures 24 | (white-pixel-texture nil) 25 | (white-color-vector nil) 26 | ;; Resources 27 | (resources (make-hash-table)) 28 | ;; Debugging 29 | (debug-key-pressed nil) 30 | (red-screen nil)) 31 | 32 | (defparameter *env* nil) 33 | 34 | (defun make-white-pixel-texture () 35 | "Sent to shaders when no image is active." 36 | (let ((texture (car (gl:gen-textures 1)))) 37 | (gl:bind-texture :texture-2d texture) 38 | (gl:tex-parameter :texture-2d :texture-min-filter :linear) 39 | (gl:tex-image-2d :texture-2d 0 :rgba 1 1 0 :bgra :unsigned-byte #(255 255 255 255)) 40 | texture)) 41 | 42 | (defun initialize-environment (sketch) 43 | (with-slots ((env %env) width height y-axis) sketch 44 | (setf (env-programs env) (kit.gl.shader:compile-shader-dictionary 'sketch-programs) 45 | (env-vao env) (make-instance 'kit.gl.vao:vao :type 'sketch-vao) 46 | (env-white-pixel-texture env) (make-white-pixel-texture) 47 | (env-white-color-vector env) #(255 255 255 255) 48 | (env-pen env) (make-default-pen) 49 | (env-font env) (make-default-font)) 50 | (initialize-view-matrix sketch) 51 | (kit.gl.shader:use-program (env-programs env) :fill-shader))) 52 | 53 | (defun initialize-view-matrix (sketch) 54 | (with-slots ((env %env) width height y-axis %viewport-changed) sketch 55 | (setf (env-view-matrix env) (if (eq y-axis :down) 56 | (kit.glm:ortho-matrix 0 width height 0 -1 1) 57 | (kit.glm:ortho-matrix 0 width 0 height -1 1)) 58 | (env-y-axis-sgn env) (if (eq y-axis :down) +1 -1) 59 | %viewport-changed t))) 60 | 61 | (defun initialize-gl (sketch) 62 | (with-slots ((w %window)) sketch 63 | (handler-case (sdl2:gl-set-swap-interval 1) 64 | ;; Some OpenGL drivers do not allow to control swapping. 65 | ;; In this case SDL2 sets an error that needs to be cleared. 66 | (sdl2::sdl-rc-error (e) 67 | (warn "VSYNC was not enabled; frame rate was not restricted to 60fps.~% ~A" e) 68 | (sdl2-ffi.functions:sdl-clear-error))) 69 | (setf (kit.sdl2:idle-render w) t) 70 | (gl:enable :blend :line-smooth :polygon-smooth) 71 | (gl:blend-func :src-alpha :one-minus-src-alpha) 72 | (gl:hint :line-smooth-hint :nicest) 73 | (gl:hint :polygon-smooth-hint :nicest) 74 | (gl:clear-color 0.0 0.0 0.0 1.0) 75 | (gl:clear :color-buffer :depth-buffer) 76 | (gl:flush))) 77 | 78 | (defmacro with-environment (env &body body) 79 | `(let ((*env* ,env)) 80 | ,@body)) 81 | -------------------------------------------------------------------------------- /src/figures.lisp: -------------------------------------------------------------------------------- 1 | ;;;; figures.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; _____ ___ ____ _ _ ____ _____ ____ 6 | ;;; | ___|_ _/ ___| | | | _ \| ____/ ___| 7 | ;;; | |_ | | | _| | | | |_) | _| \___ \ 8 | ;;; | _| | | |_| | |_| | _ <| |___ ___) | 9 | ;;; |_| |___\____|\___/|_| \_\_____|____/ 10 | 11 | (defclass figure () 12 | ((draws :initarg :draws))) 13 | 14 | (defmethod draw-figure ((figure figure)) 15 | (symbol-macrolet ((position (env-buffer-position *env*))) 16 | (with-slots (draws) figure 17 | (kit.gl.shader:uniform-matrix (env-programs *env*) :model-m 4 18 | (vector (env-model-matrix *env*))) 19 | (gl:bind-texture :texture-2d (env-white-pixel-texture *env*)) 20 | (dolist (draw draws) 21 | (let ((primitive (getf draw :primitive)) 22 | (pointer (getf draw :pointer)) 23 | (length (getf draw :length))) 24 | (when (> (* *bytes-per-vertex* (+ position length)) *buffer-size*) 25 | (start-draw)) 26 | (let ((buffer-pointer 27 | (%gl:map-buffer-range :array-buffer 28 | (* position *bytes-per-vertex*) 29 | (* length *bytes-per-vertex*) 30 | +access-mode+))) 31 | (copy-buffer pointer buffer-pointer (* length *bytes-per-vertex*)) 32 | (%gl:draw-arrays primitive position length) 33 | (setf position (+ position length)) 34 | (%gl:unmap-buffer :array-buffer))))))) 35 | 36 | (defmacro deffigure (name &optional ((&whole opt &optional w h &rest r) '(nil nil)) &body body) 37 | (declare (ignore r)) 38 | (unless (and (numberp w) (numberp h)) 39 | (warn "Defining a figure with deffigure without specifying dimensions is deprecated.") 40 | (setf w nil 41 | h nil 42 | body (cons opt body))) 43 | `(let ((*draw-sequence* nil)) 44 | (let ((*env* (make-env)) 45 | (*draw-mode* :figure)) 46 | (with-pen (make-default-pen) 47 | ,@body)) 48 | (setf *draw-sequence* (nreverse *draw-sequence*)) 49 | (let ((figure (make-instance 'figure :draws *draw-sequence*))) 50 | ,(if (numberp w) 51 | `(defun ,name (x y &optional (w ,w) (h ,h)) 52 | (with-current-matrix 53 | (translate x y) 54 | (scale (/ w ,w) (/ h ,h)) 55 | (draw-figure figure))) 56 | (progn 57 | `(defun ,name (x y) 58 | (with-current-matrix 59 | (translate x y) 60 | (draw-figure figure)))))))) 61 | -------------------------------------------------------------------------------- /src/font.lisp: -------------------------------------------------------------------------------- 1 | ;;;; font.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; _____ ___ _ _ _____ 6 | ;;; | ___/ _ \| \ | |_ _| 7 | ;;; | |_ | | | | \| | | | 8 | ;;; | _|| |_| | |\ | | | 9 | ;;; |_| \___/|_| \_| |_| 10 | 11 | (defclass font (resource) 12 | ((face :accessor font-face :initarg :face) 13 | (color :accessor font-color :initarg :color) 14 | (size :accessor font-size :initarg :size :initform 16) 15 | (line-height :accessor font-line-height :initarg :line-height :initform 1.41) 16 | (align :accessor font-align :initarg :align :initform :left))) 17 | 18 | (defun make-font (&key face color size line-height align) 19 | (let* ((*env* (or *env* (make-env)))) 20 | (make-instance 'font 21 | :face (or face 22 | (font-face (or (env-font *env*) 23 | (make-default-font)))) 24 | :color (or color +black+) 25 | :size (coerce (truncate (or size 18)) 26 | '(signed-byte 32)) 27 | :line-height (or line-height 1.41) 28 | :align (or align :left)))) 29 | 30 | (defmacro with-font (font &body body) 31 | (with-shorthand (font make-font) 32 | (alexandria:with-gensyms (previous-font) 33 | `(let ((,previous-font (env-font *env*))) 34 | (unwind-protect (progn 35 | (setf (env-font *env*) ,font) 36 | ,@body) 37 | (setf (env-font *env*) ,previous-font)))))) 38 | 39 | (defun set-font (font) 40 | (setf (env-font *env*) font)) 41 | 42 | (defun text-scale (resources spacing width height) 43 | (let ((rendered-width (apply #'max (mapcar #'image-width resources))) 44 | (rendered-height (+ (* (- (length resources) 1) spacing) 45 | (apply #'+ (mapcar #'image-height resources))))) 46 | (cond ((and (not (numberp width)) (not (numberp height))) (list 1 1)) 47 | ((null width) (list 1 (/ height rendered-height))) 48 | ((null height) (list (/ width rendered-width) 1)) 49 | ((eq :keep-ratio width) (list (/ height rendered-height) (/ height rendered-height))) 50 | ((eq :keep-ratio height) (list (/ width rendered-width) (/ width rendered-width))) 51 | (t (list (/ width rendered-width) (/ height rendered-height)))))) 52 | 53 | (defun text-align (align width) 54 | (cond ((eq align :right) (- width)) 55 | ((eq align :center) (- (round (/ width 2)))) 56 | (t 0))) 57 | 58 | (defun text-line-image (line) 59 | (let* ((line (if (> (length line) 0) line " ")) 60 | (font (env-font *env*)) 61 | (typeface (and font (load-resource (typeface-filename (font-face font)) 62 | :size (font-size font))))) 63 | (destructuring-bind (r g b a) (color-rgba-255 (font-color font)) 64 | (make-image-from-surface (sdl2-ttf:render-utf8-blended 65 | (typeface-pointer typeface) 66 | line r g b a) 67 | :free-surface :font)))) 68 | 69 | (defun text (text-string x y &optional width height) 70 | (let* ((font (env-font *env*))) 71 | (when (and font (> (length text-string) 0)) 72 | (with-pen (make-pen :stroke nil) 73 | (let* ((top 0) 74 | (lines (split-sequence:split-sequence #\newline text-string)) 75 | (resources (mapcar #'text-line-image lines)) 76 | (spacing (* (font-size font) (font-line-height font))) 77 | (scale (text-scale resources spacing width height))) 78 | (dolist (resource resources) 79 | (image resource 80 | (+ x (text-align (font-align font) (* (first scale) (image-width resource)))) 81 | (+ y top) 82 | (* (first scale) (image-width resource)) 83 | (* (second scale) (image-height resource))) 84 | (incf top (* (second scale) spacing)) 85 | (gl:delete-textures (list (image-texture resource))))))))) 86 | 87 | (let ((font)) 88 | (defun make-default-font () 89 | (setf font (or font 90 | (let ((filename (relative-path "res/sourcesans/SourceSansPro-Regular.otf"))) 91 | (make-font :face (make-instance 'typeface 92 | :filename filename 93 | :pointer (sdl2-ttf:open-font filename 18)) 94 | :color +black+ 95 | :size 18)))))) 96 | 97 | (let ((font)) 98 | (defun make-error-font () 99 | (setf font (or font 100 | (let ((filename (relative-path "res/sourcesans/SourceSansPro-Regular.otf"))) 101 | (make-font :face (make-instance 'typeface 102 | :filename filename 103 | :pointer (sdl2-ttf:open-font filename 16)) 104 | :color +white+ 105 | :size 16)))))) 106 | -------------------------------------------------------------------------------- /src/geometry.lisp: -------------------------------------------------------------------------------- 1 | ;;;; geometry.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ _____ ___ __ __ _____ _____ ______ __ 6 | ;;; / ___| ____/ _ \| \/ | ____|_ _| _ \ \ / / 7 | ;;; | | _| _|| | | | |\/| | _| | | | |_) \ V / 8 | ;;; | |_| | |__| |_| | | | | |___ | | | _ < | | 9 | ;;; \____|_____\___/|_| |_|_____| |_| |_| \_\|_| 10 | 11 | (defun edges (vertices &optional (closed t)) 12 | (loop 13 | for i in (if closed 14 | (append (last vertices) (butlast vertices)) 15 | (butlast vertices)) 16 | for j in (if closed 17 | vertices 18 | (cdr vertices)) 19 | collect (list i j))) 20 | 21 | (defmacro with-lines (lines &body body) 22 | (flet ((i-to-s (i) (format nil "~a" i))) 23 | `(symbol-macrolet 24 | ,(loop 25 | for line in lines 26 | for i upfrom 0 by 2 27 | append 28 | (loop 29 | for sym in '(x x y y) 30 | for idx in '(1 2 1 2) 31 | for line-accessor in '(caar caadr cadar cadadr) 32 | collect 33 | `(,(alexandria:symbolicate sym (i-to-s (+ i idx))) 34 | (,line-accessor ,line)))) 35 | ,@body))) 36 | 37 | (defun translate-line (line d) 38 | (with-lines (line) 39 | (let* ((a (atan (- y2 y1) (- x2 x1))) 40 | (dx (* (sin a) d)) 41 | (dy (* (cos a) d))) 42 | `((,(+ x1 dx) ,(- y1 dy)) (,(+ x2 dx) ,(- y2 dy)))))) 43 | 44 | (defun intersect-lines (line1 line2) 45 | ;; https://en.wikipedia.org/wiki/Line–line_intersection#Given_two_points_on_each_line 46 | ;; The algorithm is changed so that division by zero never happens. 47 | ;; The values that are returned for "intersection" may or may not make sense, but 48 | ;; having responsive but wrong sketch is much better than a red screen. 49 | (with-lines (line1 line2) 50 | (let* ((denominator (- (* (- x1 x2) (- y3 y4)) 51 | (* (- y1 y2) (- x3 x4)))) 52 | (a (if (zerop denominator) 53 | (/ (+ x2 x3) 2) 54 | (/ (- (* (- (* x1 y2) (* y1 x2)) (- x3 x4)) 55 | (* (- (* x3 y4) (* y3 x4)) (- x1 x2))) 56 | denominator))) 57 | (b (if (zerop denominator) 58 | (/ (+ y2 y3) 2) 59 | (/ (- (* (- (* x1 y2) (* y1 x2)) (- y3 y4)) 60 | (* (- (* x3 y4) (* y3 x4)) (- y1 y2))) 61 | denominator)))) 62 | (list a b)))) 63 | 64 | (defun grow-polygon (polygon d) 65 | (let ((polygon 66 | (mapcar (lambda (x) (apply #'intersect-lines x)) 67 | (edges (mapcar (lambda (x) (translate-line x (- d))) 68 | (edges polygon)))))) 69 | (append (cdr polygon) (list (car polygon))))) 70 | 71 | (defun triangulate (polygon) 72 | (let ((points (group polygon))) 73 | (apply #'append 74 | (glu-tessellate:tessellate 75 | (make-array (length points) :initial-contents points) 76 | :winding-rule (pen-winding-rule (env-pen *env*)))))) 77 | 78 | (defun bounding-box (vertices) 79 | (loop for (x y) in vertices 80 | minimize x into min-x 81 | maximize x into max-x 82 | minimize y into min-y 83 | maximize y into max-y 84 | finally (return (list (list min-x min-y) (list max-x max-y))))) 85 | 86 | (defun normalize-to-bounding-box (vertices) 87 | (let ((box (bounding-box vertices))) 88 | (with-lines (box) 89 | (mapcar (lambda (vertex) 90 | (list (normalize (first vertex) x1 x2) 91 | (normalize (second vertex) y1 y2))) 92 | vertices)))) 93 | -------------------------------------------------------------------------------- /src/image.lisp: -------------------------------------------------------------------------------- 1 | ;;;; resources.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;; ___ __ __ _ ____ _____ ____ 6 | ;; |_ _| \/ | / \ / ___| ____/ ___| 7 | ;; | || |\/| | / _ \| | _| _| \___ \ 8 | ;; | || | | |/ ___ \ |_| | |___ ___) | 9 | ;; |___|_| |_/_/ \_\____|_____|____/ 10 | 11 | (defmethod draw ((image image) &key (x 0) (y 0) width height mode &allow-other-keys) 12 | "Draws an image, X and Y values are 0 by default, while WIDTH and HEIGHT 13 | are set to the width & height of the image if not provided." 14 | (declare (ignore mode)) 15 | (with-pen (make-pen :fill image :stroke nil) 16 | (rect x 17 | y 18 | (or (abs-or-rel width (image-width image))) 19 | (or (abs-or-rel height (image-height image)))))) 20 | 21 | (defun image (image-resource x y &optional width height) 22 | "***Deprecated***, use the DRAW method." 23 | (draw image-resource :x x :y y :width width :height height)) 24 | 25 | (defmethod crop ((image-resource image) x y w h) 26 | "Generate a cropped image resource from IMAGE-RESOURCE, limiting how much 27 | of the image is drawn to the rect of X,Y,W,H, which are all in pixel values, and 28 | X & Y are relative to the image." 29 | (cropped-image-from-image image-resource x y w h)) 30 | 31 | (defun save-png (pathname) 32 | (let ((width (sketch-width *sketch*)) 33 | (height (sketch-height *sketch*))) 34 | (flet ((ptr (vec offset) 35 | (static-vectors:static-vector-pointer vec :offset offset)) 36 | (from (row col width) 37 | (+ col (* row (* 4 width)))) 38 | (to (row col width height) 39 | (+ col (* (- height row 1) 4 width)))) 40 | (static-vectors:with-static-vector (buffer (* 4 width height)) 41 | (%gl:read-pixels 0 0 width height :rgba :unsigned-byte (ptr buffer 0)) 42 | (dotimes (row (truncate height 2)) 43 | (dotimes (col (* 4 width)) 44 | (rotatef (cffi:mem-aref (ptr buffer (from row col width)) :uint8) 45 | (cffi:mem-aref (ptr buffer (to row col width height)) :uint8)))) 46 | (let ((png (make-instance 'zpng:png 47 | :width width 48 | :height height 49 | :color-type :truecolor-alpha 50 | :image-data buffer))) 51 | (zpng:write-png png pathname)))))) 52 | -------------------------------------------------------------------------------- /src/math.lisp: -------------------------------------------------------------------------------- 1 | ;;;; math.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; __ __ _ _____ _ _ 6 | ;;; | \/ | / \|_ _| | | | 7 | ;;; | |\/| | / _ \ | | | |_| | 8 | ;;; | | | |/ ___ \| | | _ | 9 | ;;; |_| |_/_/ \_\_| |_| |_| 10 | 11 | ;; Calculation 12 | 13 | (defun clamp-1 (x) 14 | (alexandria:clamp x 0.0 1.0)) 15 | 16 | (defun normalize (x low high &key (clamp t) (out-low 0.0) (out-high 1.0)) 17 | (let ((low (min low high)) 18 | (high (max low high)) 19 | (min-out-low (min out-low out-high)) 20 | (min-out-high (max out-low out-high))) 21 | (let ((norm (+ out-low 22 | (* (- out-high out-low) 23 | (/ (- x low) (- high low)))))) 24 | (if clamp (alexandria:clamp norm min-out-low min-out-high) norm)))) 25 | 26 | ;; Trigonometry 27 | 28 | (defconstant +pi+ PI) 29 | (defconstant +two-pi+ (* PI 2)) 30 | (defconstant +tau+ +two-pi+) 31 | (defconstant +half-pi+ (/ PI 2)) 32 | (defconstant +quarter-pi+ (/ PI 4)) 33 | (defconstant +epsilon+ single-float-epsilon) 34 | (defconstant +phi+ (/ (1+ (sqrt 5d0)) 2)) 35 | (defconstant +golden-ratio+ +phi+) 36 | (defconstant +e+ (exp 1d0)) 37 | 38 | (defun radians (deg) 39 | (* PI (/ deg 180))) 40 | 41 | (defun degrees (rad) 42 | (* 180 (/ rad PI))) 43 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (uiop:define-package #:sketch 4 | (:use #:cl) 5 | (:import-from :kit.sdl2 6 | :mousebutton-event 7 | :mousemotion-event 8 | :mousewheel-event 9 | :textinput-event 10 | :keyboard-event 11 | :other-event 12 | :close-window) 13 | (:export :sketch 14 | :setup 15 | :draw 16 | 17 | :defsketch 18 | 19 | :sketch-title 20 | :sketch-width 21 | :sketch-height 22 | :sketch-fullscreen 23 | :sketch-resizable 24 | :sketch-copy-pixels 25 | :sketch-y-axis 26 | :sketch-close-on 27 | 28 | :title 29 | :width 30 | :height 31 | :fullscreen 32 | :resizable 33 | :copy-pixels 34 | :y-axis 35 | :close-on 36 | 37 | :*default-width* 38 | :*default-height* 39 | 40 | ;; Math 41 | :clamp-1 42 | :normalize 43 | 44 | :+pi+ 45 | :+two-pi+ 46 | :+tau+ 47 | :+half-pi+ 48 | :+quarter-pi+ 49 | :+epsilon+ 50 | :+phi+ 51 | :+golden-ratio+ 52 | :+e+ 53 | 54 | :radians 55 | :degrees 56 | 57 | ;; Utils 58 | :relative-path 59 | 60 | ;; Colors 61 | :color 62 | :make-color 63 | :color-red 64 | :color-green 65 | :color-blue 66 | :color-hue 67 | :color-saturation 68 | :color-brightness 69 | :color-alpha 70 | :rgb-to-hsb 71 | :hsb-to-rgb 72 | :rgb 73 | :hsb 74 | :gray 75 | :rgb-255 76 | :hsb-360 77 | :gray-255 78 | :hex-to-color 79 | :color-rgb 80 | :color-rgba 81 | :color-hsba 82 | :color-vector 83 | :color-vector-255 84 | :lerp-color 85 | :random-color 86 | :hash-color 87 | :color-filter-grayscale 88 | :color-filter-invert 89 | :color-filter-rotate 90 | :color-filter-hsb 91 | :+red+ 92 | :+green+ 93 | :+blue+ 94 | :+yellow+ 95 | :+magenta+ 96 | :+cyan+ 97 | :+orange+ 98 | :+white+ 99 | :+black+ 100 | :+gray+ 101 | :+indigo+ 102 | 103 | ;; Pen 104 | :pen 105 | :pen-stroke 106 | :pen-fill 107 | :pen-weight 108 | :pen-curve-steps 109 | :pen-winding-rule 110 | :make-pen 111 | :set-pen 112 | :copy-pen 113 | :flip-pen 114 | :with-pen 115 | :background 116 | 117 | ;; Shapes 118 | :point 119 | :line 120 | :polyline 121 | :rect 122 | :ngon 123 | :star 124 | :ellipse 125 | :circle 126 | :polygon 127 | :bezier 128 | 129 | ;; Transforms 130 | :set-matrix 131 | :push-matrix 132 | :pop-matrix 133 | :translate 134 | :rotate 135 | :scale 136 | :with-matrix 137 | :with-identity-matrix 138 | :with-current-matrix 139 | :with-translate 140 | :with-rotate 141 | :with-scale 142 | 143 | ;; Complex transforms 144 | :fit 145 | :with-fit 146 | 147 | ;; Channels 148 | :register-input 149 | :in 150 | :out 151 | :define-channel-observer 152 | :define-named-channel-observer 153 | :reset-all-channels 154 | 155 | ;; Figures 156 | :deffigure 157 | 158 | ;; Entities 159 | :defentity 160 | :entity-width 161 | :entity-height 162 | 163 | ;; Resources 164 | :load-resource 165 | :image 166 | :image-width 167 | :image-height 168 | :crop 169 | :with-uv-rect 170 | :save-png 171 | 172 | ;; Font 173 | :make-font 174 | :with-font 175 | :set-font 176 | :text 177 | :text-line-image 178 | 179 | ;; Canvas 180 | :make-canvas 181 | :canvas-reset 182 | :canvas-paint 183 | :canvas-image 184 | :canvas-lock 185 | :canvas-unlock 186 | :canvas-width 187 | :canvas-height 188 | 189 | ;; Controllers 190 | :on-click 191 | :on-mouse-button 192 | :on-mouse-left 193 | :on-mouse-middle 194 | :on-mouse-right 195 | :on-mouse-left-up 196 | :on-mouse-left-down 197 | :on-mouse-middle-up 198 | :on-mouse-middle-down 199 | :on-mouse-right-up 200 | :on-mouse-right-down 201 | :on-hover 202 | :on-enter 203 | :on-leave 204 | :on-text 205 | :on-key 206 | 207 | ;; Control flow 208 | :start-loop 209 | :stop-loop 210 | )) 211 | -------------------------------------------------------------------------------- /src/pen.lisp: -------------------------------------------------------------------------------- 1 | ;;;; pen.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ _____ _ _ 6 | ;;; | _ \| ____| \ | | 7 | ;;; | |_) | _| | \| | 8 | ;;; | __/| |___| |\ | 9 | ;;; |_| |_____|_| \_| 10 | 11 | (defstruct pen 12 | (fill nil) 13 | (stroke nil) 14 | (weight 1) 15 | (curve-steps 100) 16 | (winding-rule :nonzero 17 | :type (member :odd :nonzero :positive :negative :abs-geq-two))) 18 | 19 | (defmacro with-pen (pen &body body) 20 | (with-shorthand (pen make-pen) 21 | (alexandria:with-gensyms (previous-pen) 22 | `(let ((,previous-pen (env-pen *env*))) 23 | (unwind-protect (progn 24 | (setf (env-pen *env*) ,pen) 25 | ,@body) 26 | (setf (env-pen *env*) ,previous-pen)))))) 27 | 28 | (defun set-pen (pen) 29 | "Sets environment pen to PEN." 30 | (setf (env-pen *env*) pen)) 31 | 32 | (defun flip-pen (pen) 33 | "Makes a new pen by swapping PEN's fill and stroke colors." 34 | (make-pen :weight (pen-weight pen) 35 | :stroke (pen-fill pen) 36 | :fill (pen-stroke pen) 37 | :weight (pen-weight pen) 38 | :curve-steps (pen-curve-steps pen) 39 | :winding-rule (pen-winding-rule pen))) 40 | 41 | (defun background (color) 42 | "Fills the sketch window with COLOR." 43 | (apply #'gl:clear-color (color-rgba color)) 44 | (gl:clear :color-buffer)) 45 | 46 | (let ((pen)) 47 | (defun make-default-pen () 48 | (setf pen (or pen 49 | (make-pen :weight 1 50 | :fill +white+ 51 | :stroke +black+))))) 52 | -------------------------------------------------------------------------------- /src/resources.lisp: -------------------------------------------------------------------------------- 1 | ;;;; resources.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ _____ ____ ___ _ _ ____ ____ _____ ____ 6 | ;;; | _ \| ____/ ___| / _ \| | | | _ \ / ___| ____/ ___| 7 | ;;; | |_) | _| \___ \| | | | | | | |_) | | | _| \___ \ 8 | ;;; | _ <| |___ ___) | |_| | |_| | _ <| |___| |___ ___) | 9 | ;;; |_| \_\_____|____/ \___/ \___/|_| \_\\____|_____|____/ 10 | 11 | ;;; Classes 12 | 13 | (defclass resource () ()) 14 | 15 | (defclass image (resource) 16 | ((texture :accessor image-texture :initarg :texture) 17 | (width :accessor image-width :initarg :width) 18 | (height :accessor image-height :initarg :height))) 19 | 20 | (defclass cropped-image (image) 21 | ((uv-rect :accessor cropped-image-uv-rect :initarg :uv-rect) 22 | (original-image :accessor original-image :initarg :original-image))) 23 | 24 | (defmethod image-texture ((instance cropped-image)) 25 | (image-texture (original-image instance))) 26 | 27 | (defun pixel-uv-rect (img x y w h) 28 | "Generate uv coordinates (0.0 to 1.0) for portion of IMG within 29 | the rect specified by X Y W H 30 | Image flipping can be done by using negative width and height values" 31 | (with-slots (width height) img 32 | (list (coerce-float (/ x width)) 33 | (coerce-float (/ y height)) 34 | (coerce-float (/ w width)) 35 | (coerce-float (/ h height))))) 36 | 37 | (defun cropped-image-from-image (image x y w h) 38 | (make-instance 'cropped-image 39 | :texture nil 40 | :width w 41 | :height h 42 | :uv-rect (pixel-uv-rect image x y w h) 43 | :original-image image)) 44 | 45 | (defclass typeface (resource) 46 | ((filename :accessor typeface-filename :initarg :filename) 47 | (pointer :accessor typeface-pointer :initarg :pointer))) 48 | 49 | ;;; Loading 50 | 51 | (defun file-name-extension (name) 52 | ;; taken from dto's xelf code 53 | (let ((pos (position #\. name :from-end t))) 54 | (when (numberp pos) 55 | (subseq name (1+ pos))))) 56 | 57 | (defun load-resource (filename &rest all-keys &key type force-reload-p &allow-other-keys) 58 | (let ((*env* (or *env* (make-env)))) ;; try faking env if we still don't have one 59 | (symbol-macrolet ((resource (gethash key (env-resources *env*)))) 60 | (alexandria:remove-from-plistf all-keys :force-reload-p) 61 | (let* ((key (alexandria:make-keyword 62 | (alexandria:symbolicate filename (format nil "~a" all-keys))))) 63 | (when force-reload-p 64 | (free-resource resource) 65 | (remhash key (env-resources *env*))) 66 | (when (not resource) 67 | (setf resource 68 | (apply #'load-typed-resource 69 | (list* filename 70 | (or type 71 | (case (alexandria:make-keyword 72 | (alexandria:symbolicate 73 | (string-upcase (file-name-extension filename)))) 74 | ((:png :jpg :jpeg :tga :gif :bmp) :image) 75 | ((:ttf :otf) :typeface))) 76 | all-keys)))) 77 | resource)))) 78 | 79 | (defgeneric load-typed-resource (filename type &key &allow-other-keys)) 80 | 81 | (defmethod load-typed-resource (filename type &key &allow-other-keys) 82 | (if (not type) 83 | (error (format nil "~a's type cannot be deduced." filename)) 84 | (error (format nil "Unsupported resource type ~a" type)))) 85 | 86 | (defun make-image-from-surface (surface &key (free-surface t) 87 | (min-filter :linear) 88 | (mag-filter :linear)) 89 | (let ((image (make-instance 'image 90 | :width (sdl2:surface-width surface) 91 | :height (sdl2:surface-height surface) 92 | :texture nil))) 93 | (init-image-texture! image 94 | surface 95 | :free-surface free-surface 96 | :min-filter min-filter 97 | :mag-filter mag-filter) 98 | image)) 99 | 100 | (defmethod load-typed-resource (filename (type (eql :image)) 101 | &key (min-filter :linear) 102 | (mag-filter :linear) 103 | (x nil) 104 | (y nil) 105 | (w nil) 106 | (h nil) 107 | &allow-other-keys) 108 | (make-image-from-surface 109 | (cut-surface (sdl2-image:load-image filename) x y w h) 110 | :min-filter min-filter 111 | :mag-filter mag-filter)) 112 | 113 | (defun init-image-texture! (image surface &key (free-surface t) 114 | (min-filter :linear) 115 | (mag-filter :linear)) 116 | (flet ((init () 117 | (let ((texture (car (gl:gen-textures 1))) 118 | (rgba-surface 119 | (if (eq (sdl2:surface-format-format surface) sdl2:+pixelformat-rgba32+) 120 | surface 121 | (sdl2:convert-surface-format surface sdl2:+pixelformat-rgba32+)))) 122 | (gl:bind-texture :texture-2d texture) 123 | (gl:tex-parameter :texture-2d :texture-min-filter min-filter) 124 | (gl:tex-parameter :texture-2d :texture-mag-filter mag-filter) 125 | (gl:pixel-store :unpack-row-length (/ (sdl2:surface-pitch rgba-surface) 4)) 126 | (gl:tex-image-2d :texture-2d 0 :rgba 127 | (sdl2:surface-width rgba-surface) 128 | (sdl2:surface-height rgba-surface) 129 | 0 130 | :rgba 131 | :unsigned-byte (sdl2:surface-pixels rgba-surface)) 132 | (gl:bind-texture :texture-2d 0) 133 | (unless (eq rgba-surface surface) (sdl2:free-surface rgba-surface)) 134 | (when free-surface 135 | (when (eq free-surface :font) 136 | (tg:cancel-finalization surface)) 137 | (sdl2:free-surface surface)) 138 | (setf (image-texture image) texture)))) 139 | (if (delay-init-p) 140 | (add-delayed-init-fun! #'init) 141 | (init)))) 142 | 143 | (defun cut-surface (surface x y w h) 144 | (if (and x y w h) 145 | (let ((src-rect (sdl2:make-rect x y w h)) 146 | (dst-rect (sdl2:make-rect 0 0 w h)) 147 | (dst-surface (sdl2-ffi.functions:sdl-create-rgb-surface-with-format 148 | 0 w h 32 149 | (surface-format surface)))) 150 | (sdl2-ffi.functions:sdl-set-surface-blend-mode surface sdl2-ffi:+sdl-blendmode-none+) 151 | (sdl2:blit-surface surface src-rect dst-surface dst-rect) 152 | (sdl2:free-surface surface) 153 | dst-surface) 154 | surface)) 155 | 156 | (defmethod load-typed-resource (filename (type (eql :typeface)) 157 | &key (size 18) &allow-other-keys) 158 | (make-instance 'typeface 159 | :filename filename 160 | :pointer (sdl2-ttf:open-font filename 161 | (coerce (truncate size) 162 | '(signed-byte 32))))) 163 | 164 | (defgeneric free-resource (resource)) 165 | 166 | (defmethod free-resource ((resource (eql nil)))) 167 | 168 | (defmethod free-resource ((image image)) 169 | (gl:delete-textures (list (image-texture image)))) 170 | 171 | (defmethod free-resource ((typeface typeface)) 172 | (let ((pointer (typeface-pointer typeface))) 173 | (setf (typeface-pointer typeface) nil) 174 | (sdl2-ttf:close-font pointer))) 175 | -------------------------------------------------------------------------------- /src/shaders.lisp: -------------------------------------------------------------------------------- 1 | ;;;; shaders.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ _ _ _ ____ _____ ____ ____ 6 | ;;; / ___|| | | | / \ | _ \| ____| _ \/ ___| 7 | ;;; \___ \| |_| | / _ \ | | | | _| | |_) \___ \ 8 | ;;; ___) | _ |/ ___ \| |_| | |___| _ < ___) | 9 | ;;; |____/|_| |_/_/ \_\____/|_____|_| \_\____/ 10 | 11 | (kit.gl.shader:defdict sketch-programs () 12 | (kit.gl.shader:program :fill-shader (:view-m :model-m :texid) 13 | (:vertex-shader " 14 | #version 330 core 15 | 16 | uniform mat4 model_m; 17 | uniform mat4 view_m; 18 | 19 | layout (location = 0) in vec2 vertex; 20 | layout (location = 1) in vec2 texcoord; 21 | layout (location = 2) in vec4 color; 22 | 23 | smooth out vec4 f_color; 24 | smooth out vec2 f_texcoord; 25 | 26 | void main() { 27 | gl_Position = view_m * model_m * vec4(vertex, 0.0, 1.0); 28 | f_texcoord = texcoord; 29 | f_color = color; 30 | } 31 | ") 32 | (:fragment-shader " 33 | #version 330 core 34 | 35 | uniform sampler2D texid; 36 | 37 | smooth in vec4 f_color; 38 | smooth in vec2 f_texcoord; 39 | 40 | out vec4 f_out; 41 | 42 | void main() { 43 | f_out = texture(texid, f_texcoord) * f_color; 44 | } 45 | "))) 46 | -------------------------------------------------------------------------------- /src/shapes.lisp: -------------------------------------------------------------------------------- 1 | ;;;; shapes.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; ____ _ _ _ ____ _____ ____ 6 | ;;; / ___|| | | | / \ | _ \| ____/ ___| 7 | ;;; \___ \| |_| | / _ \ | |_) | _| \___ \ 8 | ;;; ___) | _ |/ ___ \| __/| |___ ___) | 9 | ;;; |____/|_| |_/_/ \_\_| |_____|____/ 10 | 11 | (defun point (x y) 12 | (declare (type real x y)) 13 | (let ((weight (or (pen-weight (env-pen *env*)) 1))) 14 | (with-pen (make-pen :fill (pen-stroke (env-pen *env*))) 15 | (circle x y (/ weight 2))))) 16 | 17 | (defun make-line (x1 y1 x2 y2) 18 | (let* ((a (atan (- y2 y1) (- x2 x1))) 19 | (w (/ (or (pen-weight (env-pen *env*)) 1) 2)) 20 | (dx (* (sin a) w)) 21 | (dy (* (cos a) w))) 22 | (lambda () 23 | (draw-shape 24 | :triangle-strip 25 | `((,(- x1 dx) ,(+ y1 dy)) 26 | (,(- x2 dx) ,(+ y2 dy)) 27 | (,(+ x1 dx) ,(- y1 dy)) 28 | (,(+ x2 dx) ,(- y2 dy))) 29 | nil)))) 30 | 31 | (defun line (x1 y1 x2 y2) 32 | (declare (type real x1 y1 x2 y2)) 33 | (with-pen (flip-pen (env-pen *env*)) 34 | (funcall (make-line x1 y1 x2 y2)))) 35 | 36 | (defun translated-intersects (lines distance) 37 | (let ((lines (mapcar (lambda (x) (translate-line x distance)) lines))) 38 | (edges (append (list (caar lines)) 39 | (mapcar (lambda (x) (apply #'intersect-lines x)) 40 | (edges lines nil)) 41 | (cdar (last lines))) 42 | nil))) 43 | 44 | (defun make-polyline (&rest coordinates) 45 | (multiple-value-bind (d+ d-) 46 | (div2-inexact (pen-weight (env-pen *env*))) 47 | (let* ((lines (edges (group coordinates) nil)) 48 | (lefts (translated-intersects lines (+ d+))) 49 | (rights (translated-intersects lines (- d-)))) 50 | (lambda () 51 | (draw-shape 52 | :triangle-strip 53 | (mix-lists (apply #'append lefts) 54 | (apply #'append rights)) 55 | nil))))) 56 | 57 | (defun polyline (&rest coordinates) 58 | (case (pen-weight (env-pen *env*)) 59 | (nil nil) 60 | (1 (mapcar (lambda (x) (line (caar x) (cadar x) (caadr x) (cadadr x))) 61 | (edges (group coordinates) nil))) 62 | (t (with-pen (flip-pen (env-pen *env*)) 63 | (funcall (apply #'make-polyline coordinates)))))) 64 | 65 | (defun make-rect (x y w h) 66 | (if (and (plusp w) (plusp h)) 67 | (lambda () 68 | (draw-shape 69 | :triangle-strip 70 | `((,x ,(+ y h)) (,x ,y) (,(+ x w) ,(+ y h)) (,(+ x w) ,y)) 71 | `((,x ,y) (,x ,(+ y h)) (,(+ x w) ,(+ y h)) (,(+ x w) ,y)))) 72 | (lambda ()))) 73 | 74 | (defun rect (x y w h) 75 | (declare (type real x y w h)) 76 | (funcall (make-rect x y w h))) 77 | 78 | (defun ngon-vertices (n cx cy rx ry &optional (angle 0)) 79 | (let* ((angle (radians angle)) 80 | (rx (if (zerop rx) +epsilon+ rx)) 81 | (theta (/ +tau+ n)) 82 | (tangential (tan theta)) 83 | (radial (cos theta)) 84 | (y-mul (/ ry rx))) 85 | (loop repeat n 86 | for x = (* (cos angle) rx) then (* radial (- x (* (- y) tangential))) 87 | and y = (* (sin angle) ry) then (* radial (- y (* x tangential))) 88 | collect `(,(+ x cx) ,(+ (* y-mul y) cy))))) 89 | 90 | (defun make-ngon (n cx cy rx ry &optional (angle 0)) 91 | (let ((vertices (ngon-vertices n cx cy rx ry angle))) 92 | (lambda () 93 | (draw-shape :triangle-fan vertices vertices)))) 94 | 95 | (defun ngon (n cx cy rx ry &optional (angle 0)) 96 | (declare (type fixnum n) 97 | (type real cx cy rx ry angle)) 98 | (funcall (make-ngon n cx cy rx ry angle))) 99 | 100 | (defun make-star (n cx cy ra rb &optional (angle 0)) 101 | (let ((vertices (mix-lists (ngon-vertices n cx cy ra ra (+ 90 angle)) 102 | (ngon-vertices n cx cy rb rb (- (+ 90 angle) (/ 180 n)))))) 103 | (lambda () 104 | (draw-shape :triangle-fan 105 | (list* (list cx cy) 106 | (car (last vertices)) 107 | vertices) 108 | vertices)))) 109 | 110 | (defun star (n cx cy ra rb &optional (angle 0)) 111 | (declare (type fixnum n) 112 | (type real cx cy ra rb angle)) 113 | (funcall (make-star n cx cy ra rb angle))) 114 | 115 | (defun ellipse (cx cy rx ry) 116 | (declare (type real cx cy rx ry)) 117 | (when (and (not (zerop rx)) (not (zerop ry))) 118 | (ngon (max 24 (truncate (* 5 (sqrt (/ (+ (abs rx) (abs ry)) 2))))) 119 | cx cy (abs rx) (abs ry)))) 120 | 121 | (defun circle (x y r) 122 | (declare (type real x y r)) 123 | (when (not (zerop r)) 124 | (ellipse x y (abs r) (abs r)))) 125 | 126 | (defun make-polygon (&rest coordinates) 127 | (list 128 | :triangles 129 | (triangulate coordinates) 130 | (group coordinates))) 131 | 132 | (defun polygon (&rest coordinates) 133 | (apply #'draw-shape (apply #'make-polygon coordinates))) 134 | 135 | (defun quadratic-bezier-point (v a b c) 136 | (let* ((d (lerp-lists v a b)) 137 | (e (lerp-lists v b c))) 138 | (lerp-lists v d e))) 139 | 140 | (defun cubic-bezier-point (v a b c d) 141 | (let* ((e (lerp-lists v a b)) 142 | (f (lerp-lists v b c)) 143 | (g (lerp-lists v c d))) 144 | (quadratic-bezier-point v e f g))) 145 | 146 | (defun bezier (x1 y1 bx1 by1 bx2 by2 x2 y2) 147 | (declare (type real x1 y1 bx1 by1 bx2 by2 x2 y2)) 148 | (let ((a (list x1 y1)) 149 | (b (list bx1 by1)) 150 | (c (list bx2 by2)) 151 | (d (list x2 y2)) 152 | (cs (max 2 (pen-curve-steps (env-pen *env*))))) 153 | (apply #'polyline 154 | (mapcan (lambda (v) (cubic-bezier-point v a b c d)) 155 | (alexandria:iota (1+ cs) :step (/ 1 cs)))))) 156 | -------------------------------------------------------------------------------- /src/sketch.lisp: -------------------------------------------------------------------------------- 1 | ;;;; sketch.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; "sketch" goes here. Hacks and glory await! 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | ;;; ;;; 10 | ;;; _|_|_| _| _| _|_|_|_| _|_|_|_|_| _|_|_| _| _| ;;; 11 | ;;; _| _| _| _| _| _| _| _| ;;; 12 | ;;; _|_| _|_| _|_|_| _| _| _|_|_|_| ;;; 13 | ;;; _| _| _| _| _| _| _| _| ;;; 14 | ;;; _|_|_| _| _| _|_|_|_| _| _|_|_| _| _| ;;; 15 | ;;; ;;; 16 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | 19 | ;;; Sketch class 20 | 21 | (defparameter *sketch* nil 22 | "The current sketch instance.") 23 | 24 | (defparameter *default-width* 400 25 | "The default width of sketch window") 26 | (defparameter *default-height* 400 27 | "The default height of sketch window") 28 | 29 | (defclass sketch () 30 | ((%env :initform (make-env) :reader sketch-%env) 31 | (%setup-called :initform nil :accessor sketch-%setup-called) 32 | (%viewport-changed :initform t) 33 | (%entities :initform (make-hash-table) :accessor sketch-%entities) 34 | (%window :initform nil :accessor sketch-%window :initarg :window) 35 | (%delayed-init-funs :initform (make-array 0 :adjustable t :fill-pointer t) 36 | :accessor sketch-%delayed-init-funs) 37 | (title :initform "Sketch" :accessor sketch-title :initarg :title) 38 | (width :initform *default-width* :accessor sketch-width :initarg :width) 39 | (height :initform *default-height* :accessor sketch-height :initarg :height) 40 | (fullscreen :initform nil :accessor sketch-fullscreen :initarg :fullscreen) 41 | (resizable :initform nil :accessor sketch-resizable :initarg :resizable) 42 | (copy-pixels :initform nil :accessor sketch-copy-pixels :initarg :copy-pixels) 43 | (y-axis :initform :down :accessor sketch-y-axis :initarg :y-axis) 44 | (close-on :initform :escape :accessor sketch-close-on :initarg :close-on))) 45 | 46 | (defclass sketch-window (kit.sdl2:gl-window) 47 | ((%sketch 48 | :initarg :sketch 49 | :accessor %sketch 50 | :documentation "The sketch associated with this window.") 51 | (%closing :initform nil :accessor window-%closing))) 52 | 53 | ;; Always enabled 54 | (defmethod kit.sdl2:render-enabled ((window sketch-window)) 55 | t) 56 | 57 | ;; So don't do anything on SETF as well 58 | (defmethod (setf kit.sdl2:render-enabled) (value (window sketch-window)) 59 | value) 60 | 61 | ;;; Non trivial sketch writers 62 | 63 | (defmacro define-sketch-writer (slot &body body) 64 | `(defmethod (setf ,(alexandria:symbolicate 'sketch- slot)) :after (value (instance sketch)) 65 | (alexandria:when-let (win (sketch-%window instance)) 66 | (let ((win (kit.sdl2:sdl-window win))) 67 | ,@body)))) 68 | 69 | (define-sketch-writer title 70 | (sdl2:set-window-title win value)) 71 | 72 | (define-sketch-writer width 73 | (sdl2:set-window-size win value (sketch-height instance)) 74 | (initialize-view-matrix instance)) 75 | 76 | (define-sketch-writer height 77 | (sdl2:set-window-size win (sketch-width instance) value) 78 | (initialize-view-matrix instance)) 79 | 80 | (define-sketch-writer fullscreen 81 | (sdl2:set-window-fullscreen win value)) 82 | 83 | (define-sketch-writer resizable 84 | (sdl2-ffi.functions:sdl-set-window-resizable 85 | win 86 | (if value sdl2-ffi:+true+ sdl2-ffi:+false+))) 87 | 88 | (define-sketch-writer y-axis 89 | (declare (ignorable win)) 90 | (initialize-view-matrix instance)) 91 | 92 | ;;; Generic functions 93 | 94 | (defgeneric prepare (instance &key &allow-other-keys) 95 | (:documentation "Generated by DEFSKETCH.")) 96 | 97 | (defgeneric setup (instance &key &allow-other-keys) 98 | (:documentation "Called before creating the sketch window.") 99 | (:method ((instance sketch) &key &allow-other-keys) ())) 100 | 101 | (defgeneric draw (instance &key x y width height mode &allow-other-keys) 102 | (:documentation "Draws the instance with set position, dimensions, and scaling mode.") 103 | (:method ((instance sketch) &key x y width height mode &allow-other-keys) 104 | "Called repeatedly after creating the sketch window, 60fps." 105 | (declare (ignore x y width height mode)) 106 | ())) 107 | 108 | ;;; Initialization 109 | 110 | (defparameter *initialized* nil) 111 | 112 | (defun initialize-sketch () 113 | (unless *initialized* 114 | (setf *initialized* t) 115 | (kit.sdl2:init) 116 | (sdl2-ttf:init) 117 | (sdl2:in-main-thread () 118 | (sdl2:gl-set-attr :multisamplebuffers 1) 119 | (sdl2:gl-set-attr :multisamplesamples 4) 120 | 121 | (sdl2:gl-set-attr :context-major-version 3) 122 | (sdl2:gl-set-attr :context-minor-version 3) 123 | (sdl2:gl-set-attr :context-profile-mask 1)))) 124 | 125 | (defmethod initialize-instance :around ((instance sketch) &key &allow-other-keys) 126 | (initialize-sketch) 127 | (sdl2:in-main-thread () 128 | (call-next-method)) 129 | (kit.sdl2:start)) 130 | 131 | (defmethod initialize-instance :after ((instance sketch) &rest initargs &key &allow-other-keys) 132 | (apply #'prepare instance initargs) 133 | (setf (sketch-%window instance) 134 | (make-instance 'sketch-window 135 | :title (sketch-title instance) 136 | :w (sketch-width instance) 137 | :h (sketch-height instance) 138 | :fullscreen (sketch-fullscreen instance) 139 | :resizable (sketch-resizable instance) 140 | :sketch instance)) 141 | (initialize-environment instance) 142 | (initialize-gl instance) 143 | ;; These will have been added in the call to PREPARE. 144 | (with-slots ((fs %delayed-init-funs)) instance 145 | (loop for f across fs 146 | do (funcall f)) 147 | (setf fs (make-array 0 :adjustable t :fill-pointer t)))) 148 | 149 | (defmethod update-instance-for-redefined-class :after 150 | ((instance sketch) added-slots discarded-slots property-list &rest initargs) 151 | (declare (ignore added-slots discarded-slots property-list)) 152 | (apply #'prepare instance initargs) 153 | (setf (sketch-%setup-called instance) nil) 154 | (setf (slot-value instance '%entities) (make-hash-table))) 155 | 156 | ;;; Error handling 157 | 158 | (defvar *%unwind-and-call-on-error-function*) 159 | (defmacro unwind-and-call-on-error () `(funcall *%unwind-and-call-on-error-function*)) 160 | 161 | (defmethod on-error-handler ((sketch sketch) stage error) 162 | (declare (ignorable sketch stage)) 163 | (when (env-debug-key-pressed *env*) 164 | (with-simple-restart (:red-screen "Show red screen") 165 | (signal error))) 166 | (unwind-and-call-on-error)) 167 | 168 | (defmethod on-error ((sketch sketch) stage error) 169 | (declare (ignorable sketch)) 170 | (background (ecase stage 171 | (:setup (rgb 0.4 0.2 0.1)) 172 | (:draw (rgb 0.7 0 0)))) 173 | (with-font (make-error-font) 174 | (with-identity-matrix 175 | (text (format nil "Error in ~A~%---~%~a~%---~%Click for restarts." stage error) 20 20))) 176 | (setf (env-red-screen *env*) t)) 177 | 178 | (defmacro with-error-handling ((sketch) &body body) 179 | (alexandria:with-gensyms (%error %stage) 180 | `(let (,%error ,%stage) 181 | (tagbody 182 | (handler-bind ((error 183 | (lambda (e) 184 | (setf ,%error e) 185 | (let ((*%unwind-and-call-on-error-function* 186 | (lambda () (go :error)))) 187 | (on-error-handler ,sketch 188 | ,%stage 189 | ,%error))))) 190 | (macrolet ((with-stage (stage &body body) 191 | `(progn 192 | (setf ,',%stage ,stage) 193 | ,@body))) 194 | ,@body) 195 | (go :end)) 196 | :error 197 | (on-error ,sketch ,%stage ,%error) 198 | :end 199 | (setf (env-debug-key-pressed *env*) nil))))) 200 | 201 | ;;; Rendering 202 | 203 | (defmacro with-sketch ((sketch) &body body) 204 | `(with-environment (sketch-%env ,sketch) 205 | (with-pen (make-default-pen) 206 | (with-font (make-default-font) 207 | (with-identity-matrix 208 | ,@body))))) 209 | 210 | (defmacro with-gl-draw (&body body) 211 | `(progn 212 | (start-draw) 213 | ,@body 214 | (end-draw))) 215 | 216 | (defun maybe-change-viewport (sketch) 217 | (with-slots (%env %viewport-changed width height) sketch 218 | (when %viewport-changed 219 | (kit.gl.shader:uniform-matrix (env-programs %env) :view-m 4 (vector (env-view-matrix %env))) 220 | (gl:viewport 0 0 width height) 221 | (setf %viewport-changed nil)))) 222 | 223 | (defmethod kit.sdl2:render ((win sketch-window) &aux (sketch (%sketch win))) 224 | (maybe-change-viewport sketch) 225 | (with-sketch (sketch) 226 | (with-gl-draw 227 | (with-error-handling (sketch) 228 | (unless (sketch-copy-pixels sketch) 229 | (background (gray 0.4))) 230 | (when (or (env-red-screen *env*) 231 | (not (sketch-%setup-called sketch))) 232 | (setf (env-red-screen *env*) nil 233 | (sketch-%setup-called sketch) t) 234 | (with-stage :setup 235 | (setup sketch))) 236 | (with-stage :draw 237 | (draw sketch)))))) 238 | 239 | (defmethod kit.sdl2:render ((instance sketch)) 240 | (kit.sdl2:render (sketch-%window instance))) 241 | 242 | ;;; Support for resizable windows 243 | 244 | (defmethod kit.sdl2:window-event :before ((instance sketch-window) (type (eql :size-changed)) timestamp data1 data2) 245 | (with-slots ((sketch %sketch)) instance 246 | (with-slots ((env %env) width height y-axis) sketch 247 | (setf width data1 248 | height data2) 249 | (initialize-view-matrix sketch))) 250 | (kit.sdl2:render instance)) 251 | 252 | ;;; Default events 253 | 254 | (defconstant +scancode-prefix-length+ (length "scancode-")) 255 | 256 | (defun without-sdl2-scancode-prefix (keysym) 257 | (intern (subseq (symbol-name (sdl2:scancode keysym)) 258 | +scancode-prefix-length+) 259 | (find-package "KEYWORD"))) 260 | 261 | (defmethod kit.sdl2:keyboard-event :before ((instance sketch) state timestamp repeatp keysym) 262 | (declare (ignorable timestamp repeatp)) 263 | (alexandria:when-let (close-on (sketch-close-on instance)) 264 | (when (and (eql state :keyup) (eq (without-sdl2-scancode-prefix keysym) close-on)) 265 | (kit.sdl2:close-window instance)))) 266 | 267 | (defmethod close-window :before ((instance sketch-window)) 268 | (with-environment (slot-value (%sketch instance) '%env) 269 | (loop for resource being the hash-values of (env-resources *env*) 270 | do (free-resource resource)))) 271 | 272 | (defmethod close-window :after ((instance sketch)) 273 | (when (and *build* (not (kit.sdl2:all-windows))) 274 | (sdl2-ttf:quit) 275 | (kit.sdl2:quit))) 276 | 277 | ;;; DEFSKETCH macro 278 | 279 | (defun define-sketch-defclass (name bindings) 280 | `(defclass ,name (sketch) 281 | (,@(loop for b in bindings 282 | unless (eq 'sketch (binding-prefix b)) 283 | collect `(,(binding-name b) 284 | :initarg ,(binding-initarg b) 285 | :accessor ,(binding-accessor b)))))) 286 | 287 | (defun define-sketch-channel-observers (bindings) 288 | (loop for b in bindings 289 | when (binding-channelp b) 290 | collect `(define-channel-observer 291 | ; TODO: Should this really depend on kit.sdl2? 292 | (let ((win (kit.sdl2:last-window))) 293 | (when win 294 | (setf (,(binding-accessor b) (%sketch win)) 295 | (in ,(binding-channel-name b) 296 | ,(binding-initform b)))))))) 297 | 298 | (defun define-sketch-draw-method (name bindings body) 299 | `(defmethod draw ((*sketch* ,name) &key x y width height mode &allow-other-keys) 300 | (declare (ignore x y width height mode)) 301 | (with-accessors (,@(loop for b in bindings 302 | collect `(,(binding-name b) ,(binding-accessor b)))) 303 | *sketch* 304 | ,@body))) 305 | 306 | (defun define-sketch-prepare-method (name bindings) 307 | `(defmethod prepare ((*sketch* ,name) 308 | &key ,@(loop for b in bindings 309 | collect `((,(binding-initarg b) ,(binding-name b)) 310 | ,(if (binding-defaultp b) 311 | `(,(binding-accessor b) *sketch*) 312 | (binding-initform b)))) 313 | &allow-other-keys) 314 | (setf ,@(loop for b in bindings 315 | collect `(,(binding-accessor b) *sketch*) 316 | collect (binding-name b))))) 317 | 318 | (defmacro defsketch (sketch-name binding-forms &body body) 319 | (let ((bindings (parse-bindings sketch-name binding-forms 320 | (class-bindings (find-class 'sketch))))) 321 | `(progn 322 | ,(define-sketch-defclass sketch-name bindings) 323 | ,@(define-sketch-channel-observers bindings) 324 | ,(define-sketch-prepare-method sketch-name bindings) 325 | ,(define-sketch-draw-method sketch-name bindings body) 326 | 327 | (make-instances-obsolete ',sketch-name) 328 | (find-class ',sketch-name)))) 329 | 330 | ;;; Control flow 331 | 332 | (defun stop-loop () 333 | (setf (sdl2.kit:idle-render (sketch-%window *sketch*)) nil)) 334 | 335 | (defun start-loop () 336 | (setf (sdl2.kit:idle-render (sketch-%window *sketch*)) t)) 337 | 338 | ;;; Backward compatibility. 339 | ;; Previously, the main `sketch` class inherited from 340 | ;; `kit.sdl2:gl-window`, and input was handled by specialising on methods from 341 | ;; sdl2kit. So we need to forward sdl2kit input calls to the `sketch` class for 342 | ;; old sketches that rely on that approach. 343 | (defmacro define-sdl2-forward (name (&rest args) &optional already-defined?) 344 | `(progn 345 | ;; An empty method so we don't get an error if we try to forward 346 | ;; when the user hasn't defined it. 347 | (defmethod ,name ((w sketch) ,@args)) 348 | ,@(when (not already-defined?) 349 | `((defmethod ,name ((w sketch-window) ,@args) 350 | (,name (%sketch w) ,@args) 351 | (call-next-method)))))) 352 | (define-sdl2-forward kit.sdl2:mousebutton-event (state timestamp button x y) t) 353 | (define-sdl2-forward kit.sdl2:mousemotion-event (timestamp button-mask x y xrel yrel) t) 354 | (define-sdl2-forward kit.sdl2:textinput-event (timestamp text)) 355 | (define-sdl2-forward kit.sdl2:keyboard-event (state timestamp repeatp keysym)) 356 | (define-sdl2-forward kit.sdl2:mousewheel-event (timestamp x y)) 357 | (define-sdl2-forward kit.sdl2:window-event (type timestamp data1 data2)) 358 | (define-sdl2-forward kit.sdl2:controller-added-event (c)) 359 | (define-sdl2-forward kit.sdl2:controller-removed-event (c)) 360 | (define-sdl2-forward kit.sdl2:controller-axis-motion-event (controller timestamp axis value)) 361 | (define-sdl2-forward kit.sdl2:controller-button-event (controller state timestamp button)) 362 | 363 | (defmethod kit.sdl2:idle-render ((instance sketch)) 364 | (kit.sdl2:idle-render (sketch-%window instance))) 365 | 366 | (defmethod (setf kit.sdl2:idle-render) (value (instance sketch)) 367 | (setf (kit.sdl2:idle-render (sketch-%window instance)) value)) 368 | 369 | (defmethod kit.sdl2:sdl-window ((instance sketch)) 370 | (kit.sdl2:sdl-window (sketch-%window instance))) 371 | 372 | (defmethod kit.sdl2:gl-context ((instance sketch)) 373 | (kit.sdl2:gl-context (sketch-%window instance))) 374 | 375 | (defmethod kit.sdl2:render-enabled ((instance sketch)) 376 | (kit.sdl2:render-enabled (sketch-%window instance))) 377 | 378 | (defmethod (setf kit.sdl2:render-enabled) (value (instance sketch)) 379 | (setf (kit.sdl2:render-enabled (sketch-%window instance)) value)) 380 | 381 | ;; KIT.SDL2:CLOSE-WINDOW is tricky: it should always be called on both 382 | ;; the sketch and sketch's window; but it also can be first called on 383 | ;; both the window or the sketch. 384 | ;; It also should be called in sdl2's main thread, which is done by an 385 | ;; :AROUND method defined on KIT.SDL2:WINDOW. 386 | ;; The primary method defined on the SKETCH-WINDOW should 387 | ;; (call-next-method) because there is a primary method defined on 388 | ;; GL-WINDOW. 389 | ;; Finally, the :AFTER method defined on SKETCH calls KIT.SDL2:QUIT and 390 | ;; SDL2-TTF:QUIT. 391 | (defmethod kit.sdl2:close-window ((instance sketch)) 392 | (with-slots ((window %window)) instance 393 | (setf (window-%closing window) t) 394 | (kit.sdl2:close-window window))) 395 | 396 | (defmethod kit.sdl2:close-window :around ((instance sketch-window)) 397 | (if (window-%closing instance) 398 | (call-next-method) 399 | (kit.sdl2:close-window (%sketch instance)))) 400 | 401 | ;;; Resource-handling 402 | 403 | (defun delay-init-p () 404 | "This checks whether the OpenGL context has been created yet. If not, 405 | we need to wait before initializing certain resources." 406 | (and *sketch* 407 | (null (sketch-%window *sketch*)))) 408 | 409 | (defun add-delayed-init-fun! (f) 410 | "F should be a function with no arguments." 411 | (vector-push-extend f (sketch-%delayed-init-funs *sketch*))) 412 | -------------------------------------------------------------------------------- /src/transforms.lisp: -------------------------------------------------------------------------------- 1 | ;;;; transforms.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; _____ ____ _ _ _ ____ _____ ___ ____ __ __ ____ 6 | ;;; |_ _| _ \ / \ | \ | / ___|| ___/ _ \| _ \| \/ / ___| 7 | ;;; | | | |_) | / _ \ | \| \___ \| |_ | | | | |_) | |\/| \___ \ 8 | ;;; | | | _ < / ___ \| |\ |___) | _|| |_| | _ <| | | |___) | 9 | ;;; |_| |_| \_\/_/ \_\_| \_|____/|_| \___/|_| \_\_| |_|____/ 10 | 11 | (defun set-matrix (matrix) 12 | (setf (env-model-matrix *env*) matrix)) 13 | 14 | (defun push-matrix () 15 | (push (env-model-matrix *env*) (env-matrix-stack *env*))) 16 | 17 | (defun pop-matrix () 18 | (setf (env-model-matrix *env*) (pop (env-matrix-stack *env*)))) 19 | 20 | (defun set-matrix* (matrix) 21 | (set-matrix (sb-cga:matrix* (env-model-matrix *env*) matrix))) 22 | 23 | (defun translate (dx dy) 24 | (when (or (not (zerop dx)) (not (zerop dy))) 25 | (set-matrix* (sb-cga::translate* (coerce-float dx) (coerce-float dy) 0.0)))) 26 | 27 | (defun rotate (angle &optional (cx 0) (cy 0)) 28 | (translate cx cy) 29 | (set-matrix* (sb-cga::rotate* 0.0 0.0 (coerce-float (radians angle)))) 30 | (translate (- cx) (- cy))) 31 | 32 | (defun scale (sx &optional sy (cx 0) (cy 0)) 33 | (translate cx cy) 34 | (set-matrix* (sb-cga::scale* (coerce-float sx) (coerce-float (or sy sx)) 1.0)) 35 | (translate (- cx) (- cy))) 36 | 37 | (defmacro with-matrix (matrix &body body) 38 | `(progn 39 | (push-matrix) 40 | (set-matrix ,matrix) 41 | (multiple-value-prog1 (progn ,@body) 42 | (pop-matrix)))) 43 | 44 | (defmacro with-identity-matrix (&body body) 45 | `(with-matrix sb-cga::+identity-matrix+ 46 | ,@body)) 47 | 48 | (defmacro with-current-matrix (&body body) 49 | `(with-matrix (env-model-matrix *env*) 50 | ,@body)) 51 | 52 | (defmacro with-translate ((dx dy) &body body) 53 | `(with-current-matrix 54 | (translate ,dx ,dy) 55 | ,@body)) 56 | 57 | (defmacro with-rotate ((angle &optional (cx 0) (cy 0)) &body body) 58 | `(with-current-matrix 59 | (rotate ,angle ,cx ,cy) 60 | ,@body)) 61 | 62 | (defmacro with-scale ((sx &optional sy (cx 0) (cy 0)) &body body) 63 | `(with-current-matrix 64 | (scale ,sx ,sy ,cx ,cy) 65 | ,@body)) 66 | 67 | (defun transform-vertex (vertex matrix) 68 | (let* ((vector (sb-cga:vec 69 | (coerce (car vertex) 'single-float) 70 | (coerce (cadr vertex) 'single-float) 71 | 0.0)) 72 | (transformed (sb-cga:transform-point vector matrix))) 73 | ;; TODO: This is painfully inelegant. 74 | ;; No consing should happen at this point. 75 | (list (elt transformed 0) (elt transformed 1)))) 76 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;;; utils.lisp 2 | 3 | (in-package #:sketch) 4 | 5 | ;;; _ _ _____ ___ _ ____ 6 | ;;; | | | |_ _|_ _| | / ___| 7 | ;;; | | | | | | | || | \___ \ 8 | ;;; | |_| | | | | || |___ ___) | 9 | ;;; \___/ |_| |___|_____|____/ 10 | 11 | (defparameter *build* nil) 12 | 13 | (defun pad-list (list pad length) 14 | (let ((pad-length (- length (length list)))) 15 | (if (> pad-length 0) 16 | (append (make-list pad-length :initial-element pad) 17 | list) 18 | list))) 19 | 20 | (defun group (list &optional (group-length 2)) 21 | (loop with list = (copy-list list) 22 | for tail = (nthcdr (1- group-length) list) 23 | while tail 24 | collect (shiftf list (cdr tail) nil))) 25 | 26 | (defun group-bits (x &optional (bits 8)) 27 | (loop with result = () 28 | for pos from 0 below (integer-length x) by bits 29 | do (push (ldb (byte bits pos) x) result) 30 | finally (return result))) 31 | 32 | (declaim (inline order-list)) 33 | (defun order-list (order list) 34 | (loop for o in order 35 | collect (nth o list))) 36 | 37 | (declaim (inline mix-lists)) 38 | (defun mix-lists (&rest lists) 39 | (apply #'append (apply #'mapcar #'list lists))) 40 | 41 | (declaim (inline div2-inexact)) 42 | (defun div2-inexact (a) 43 | (multiple-value-bind (x y) 44 | (floor a 2) 45 | (values x (+ x y)))) 46 | 47 | (defun abs-or-rel (val src) 48 | (if (numberp val) 49 | (cond ((< 0 val 1) (* src val)) 50 | ((<= 1 val) val) 51 | (t src)) 52 | (or src 0))) 53 | 54 | (declaim (inline lerp-list)) 55 | (defun lerp-lists (v list-a list-b) 56 | (mapcar (lambda (a b) (alexandria:lerp v a b)) list-a list-b)) 57 | 58 | (defun flatten (tree &optional (unless-test (lambda (_) (declare (ignore _)) nil))) 59 | (let (list) 60 | (labels ((traverse (subtree) 61 | (when subtree 62 | (if (and (consp subtree) (not (funcall unless-test subtree))) 63 | (progn 64 | (traverse (car subtree)) 65 | (traverse (cdr subtree))) 66 | (push subtree list))))) 67 | (traverse tree)) 68 | (nreverse list))) 69 | 70 | (defun object-to-keyword-hash (object) 71 | "Expensive operation that turns CL objects into keywords whose names 72 | are MD5 hashes of those objects, stringified. Uniqueness is not guaranteed, 73 | but may be considered unique for all practical purposes." 74 | (alexandria:make-keyword 75 | (apply #'alexandria:symbolicate 76 | (coerce (map 'array (lambda (x) (format nil "~x" x)) 77 | (md5:md5sum-string (write-to-string object))) 78 | 'list)))) 79 | 80 | (defun coerce-float (x) 81 | (coerce x 'single-float)) 82 | 83 | (defun copy-buffer (src dst length &key (src-offset 0) (dst-offset 0)) 84 | (declare (optimize (speed 3) (debug 0)) 85 | (type fixnum length src-offset dst-offset)) 86 | (loop with src* = (cffi:mem-aptr src :uint8 src-offset) 87 | with dst* = (cffi:mem-aptr dst :uint8 dst-offset) 88 | for i below length 89 | do (setf (cffi:mem-aref dst* :uint8 i) 90 | (cffi:mem-aref src* :uint8 i)))) 91 | 92 | (defun relative-path (path &optional (system 'sketch)) 93 | (if *build* 94 | path 95 | (format nil "~a" (asdf:system-relative-pathname system path)))) 96 | 97 | (defun surface-format (surface) 98 | (plus-c:c-let ((surface sdl2-ffi:sdl-surface :from surface)) 99 | (surface :format :format))) 100 | 101 | (defmacro with-shorthand ((var maker) &body body) 102 | `(let ((,var (if (and (listp ,var) (keywordp (car ,var))) 103 | (cons ',maker ,var) 104 | ,var))) 105 | ,@body)) 106 | --------------------------------------------------------------------------------