├── gpu └── bind.lisp ├── noise ├── fbm.lisp ├── simplex-helpers.lisp ├── value-noise.lisp ├── value-perlin.lisp ├── cubist.lisp ├── value-hermite.lisp ├── misc.lisp └── cellular.lisp ├── .gitignore ├── protocode ├── to-add.lisp └── iq-3d-noise.glsl ├── .editorconfig ├── conditionals └── conditional-optimizations.lisp ├── shaping-functions ├── falloff.lisp ├── to-sort.lisp ├── polynominal.lisp └── interpolation.lisp ├── textures ├── dirty-blit.lisp ├── sampling.lisp ├── cube-tex-fbos.lisp ├── hdr-cross-cube-map-loader.lisp └── draw-texture.lisp ├── math-primitives ├── atan2.lisp ├── log.lisp ├── clamping.lisp ├── mod.lisp ├── vmax.lisp ├── radical-inverse.lisp ├── docs.lisp └── remap.lisp ├── random ├── random.lisp ├── hammersley.lisp └── docs.lisp ├── streams ├── quad-streams.lisp └── buffer-streamer.lisp ├── graphing ├── axis.lisp ├── plot.lisp ├── simple.lisp ├── graph.lisp └── particle │ ├── pipeline-pgraphs.lisp │ └── particle-graph.lisp ├── README.md ├── distortion └── distortion.lisp ├── internals └── quad.lisp ├── vignette └── vignette.lisp ├── LICENSE ├── color ├── sets.lisp ├── luminance.lisp └── color-space-conversions.lisp ├── hashing ├── blum-blum-shub-hash.lisp ├── permutation-polynomial-hash.lisp ├── bsharpe-quick32-hash.lisp ├── docs.lisp └── bsharpe-fast-32-hash.lisp ├── tonemapping └── operators.lisp ├── misc.lisp ├── normals └── calculate-normals.lisp ├── easing └── easing.lisp ├── nineveh.asd ├── antialiasing └── fxaa2.lisp ├── mesh └── data │ └── primitives.lisp ├── sdf └── 2d │ └── sdf.lisp └── package.lisp /gpu/bind.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh) 2 | -------------------------------------------------------------------------------- /noise/fbm.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh) 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.fasl 3 | *.lisp-temp 4 | -------------------------------------------------------------------------------- /protocode/to-add.lisp: -------------------------------------------------------------------------------- 1 | 2 | #|| - add func for this 3 | 4 | float3 up = float3(0,1,0); 5 | float3 right = normalize(cross(up,normal)); 6 | up = cross(normal,right); 7 | 8 | ||# 9 | -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /protocode/iq-3d-noise.glsl: -------------------------------------------------------------------------------- 1 | //iq's ubiquitous 3d noise 2 | float noise(in vec3 p) 3 | { 4 | vec3 ip = floor(p), f = fract(p); 5 | f = f*f*(3.0-2.0*f); 6 | vec2 uv = (ip.xy+vec2(37.0,17.0)*ip.z) + f.xy; 7 | vec2 rg = textureLod( iChannel0, (uv+ 0.5)/256.0, 0.0 ).yx; 8 | return mix(rg.x, rg.y, f.z); 9 | } 10 | -------------------------------------------------------------------------------- /conditionals/conditional-optimizations.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.conditionals) 2 | 3 | (v-defmacro mix-step-if ((op val threshold) then else) 4 | (assert (or (eq op '>=) (eq op '<)) (op) 5 | "Nineveh: Sorry < & >= are the only allowed operators for ms-if") 6 | `(mix ,(if (eq op '>=) else then) 7 | ,(if (eq op '>=) then else) 8 | (step ,threshold ,val))) 9 | -------------------------------------------------------------------------------- /shaping-functions/falloff.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.shaping-functions) 2 | 3 | (defun-g falloff-xsq-c1 ((xsq :float)) 4 | (setf xsq (- 1.0 xsq)) 5 | (* xsq xsq)) 6 | 7 | (defun-g falloff-xsq-c2 ((xsq :float)) 8 | (setf xsq (- 1.0 xsq)) 9 | (* xsq (* xsq xsq))) 10 | 11 | (defun-g falloff-xsq-c2 ((xsq :vec4)) 12 | (setf xsq (- (v4! 1.0) xsq)) 13 | (* xsq (* xsq xsq))) 14 | -------------------------------------------------------------------------------- /textures/dirty-blit.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.textures) 2 | 3 | (defun-g dirty-blit-v ((vert :vec2)) 4 | (values 5 | (v! vert 0 1) 6 | (+ (* vert 0.5) 0.5))) 7 | 8 | (defun-g dirty-blit-f ((uv :vec2) &uniform (sam :sampler-2d)) 9 | (texture sam uv )) 10 | 11 | (defpipeline-g dirty-blit () 12 | (dirty-blit-v :vec2) 13 | (dirty-blit-f :vec2)) 14 | 15 | (defun dirty-blit-sampler (sampler) 16 | (map-g #'dirty-blit (nineveh:get-quad-stream-v2) 17 | :sam sampler)) 18 | -------------------------------------------------------------------------------- /math-primitives/atan2.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.math-primitives) 2 | 3 | (defun-g atan2 ((x :float) (y :float)) 4 | (atan y x)) 5 | 6 | (v-define-compiler-macro atan2 ((x :float) (y :float)) 7 | `(atan ,y ,x)) 8 | 9 | (defun-g atan2 ((x :vec2) (y :vec2)) 10 | (atan y x)) 11 | 12 | (v-define-compiler-macro atan2 ((x :vec2) (y :vec2)) 13 | `(atan ,y ,x)) 14 | 15 | (defun-g atan2 ((x :vec3) (y :vec3)) 16 | (atan y x)) 17 | 18 | (v-define-compiler-macro atan2 ((x :vec3) (y :vec3)) 19 | `(atan ,y ,x)) 20 | 21 | (defun-g atan2 ((x :vec4) (y :vec4)) 22 | (atan y x)) 23 | 24 | (v-define-compiler-macro atan2 ((x :vec4) (y :vec4)) 25 | `(atan ,y ,x)) 26 | -------------------------------------------------------------------------------- /random/random.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.random) 2 | 3 | (defun-g rand ((seed :vec2)) 4 | (fract (* (sin (dot (s~ seed :xy) (v! "12.9898" "78.233"))) 5 | "43758.5453"))) 6 | 7 | ;; 8 | ;; Safe alternative for when Varjo supports precision modifiers 9 | ;; 10 | ;; http://byteblacksmith.com/improvements-to-the-canonical-one-liner-glsl-ran 11 | ;; d-for-opengl-es-2-0/ 12 | ;; 13 | ;; highp float rand(vec2 co) 14 | ;; { 15 | ;; highp float a = 12.9898; 16 | ;; highp float b = 78.233; 17 | ;; highp float c = 43758.5453; 18 | ;; highp float dt= dot(co.xy ,vec2(a,b)); 19 | ;; highp float sn= mod(dt,3.14); 20 | ;; return fract(sin(sn) * c); 21 | ;; } 22 | -------------------------------------------------------------------------------- /streams/quad-streams.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.streams) 2 | 3 | (defvar *quad-stream-v2-data* 4 | (list (v! -1.0 1.0) 5 | (v! -1.0 -1.0) 6 | (v! 1.0 -1.0) 7 | (v! -1.0 1.0) 8 | (v! 1.0 -1.0) 9 | (v! 1.0 1.0))) 10 | 11 | (let ((stream nil)) 12 | (defun get-quad-stream-v2 () 13 | (declare (optimize (speed 3) (safety 1) (debug 1))) 14 | (unless stream 15 | (setf stream (make-buffer-stream 16 | (make-gpu-array *quad-stream-v2-data* 17 | :element-type :vec2 18 | :dimensions 6) 19 | :retain-arrays t))) 20 | stream)) 21 | -------------------------------------------------------------------------------- /graphing/axis.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.graphing) 2 | 3 | ;; Based on Mikael Hvidtfeldt Christensen's excellent article here: 4 | ;; http://blog.hvidtfeldts.net/index.php/2011/07/plotting-high-frequency-functions-using-a-gpu/ 5 | ;; 6 | ;; We don't use dithering on this version 7 | 8 | (defun-g axis ((uv :vec2) (xy-range :vec4) (axis-style :vec4)) 9 | (let* ((axis-thickness (w axis-style)) 10 | (axis-color (v! (s~ axis-style :xyz) 1)) 11 | (diff (/ (s~ xy-range :xz) (- (s~ xy-range :yw) (s~ xy-range :xz)))) 12 | (uv (+ uv diff))) 13 | (+ (* axis-color (smoothstep axis-thickness 0 (abs (x uv)))) 14 | (* axis-color (smoothstep axis-thickness 0 (abs (y uv))))))) 15 | -------------------------------------------------------------------------------- /math-primitives/log.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:nineveh.math-primitives) 2 | 3 | (defconstant +k-log-base-10+ (/ 1.0 (log 10.0 2))) 4 | 5 | (defun-g log10 ((n :float)) 6 | (* (log2 n) +k-log-base-10+)) 7 | 8 | (defun-g log10 ((n :vec2)) 9 | (v! (* (log2 (x n)) +k-log-base-10+) 10 | (* (log2 (y n)) +k-log-base-10+))) 11 | 12 | (defun-g log10 ((n :vec3)) 13 | (v! (* (log2 (x n)) +k-log-base-10+) 14 | (* (log2 (y n)) +k-log-base-10+) 15 | (* (log2 (z n)) +k-log-base-10+))) 16 | 17 | (defun-g log10 ((n :vec4)) 18 | (v! (* (log2 (x n)) +k-log-base-10+) 19 | (* (log2 (y n)) +k-log-base-10+) 20 | (* (log2 (z n)) +k-log-base-10+) 21 | (* (log2 (w n)) +k-log-base-10+))) 22 | -------------------------------------------------------------------------------- /random/hammersley.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.random) 2 | 3 | (defun-g hammersley-nth-2d ((length-of-series :uint) (nth :uint)) 4 | "http://holger.dammertz.org/stuff/notes_HammersleyOnHemisphere.html" 5 | (v! (/ (float nth) (float length-of-series)) 6 | (radical-inverse-vdc nth))) 7 | 8 | (defun-g hammersley-nth-hemisphere ((length-of-series :uint) (nth :uint)) 9 | "http://holger.dammertz.org/stuff/notes_HammersleyOnHemisphere.html" 10 | (let* ((ham-sample (hammersley-nth-2d nth length-of-series)) 11 | (u (x ham-sample)) 12 | (v (y ham-sample)) 13 | (φ (* v 2s0 +pi+)) 14 | (cosθ (- 1s0 u)) 15 | (sinθ (sqrt (- 1 (* cosθ cosθ))))) 16 | (v! (* (cos φ) sinθ) 17 | (* (sin φ) sinθ) 18 | cosθ))) 19 | -------------------------------------------------------------------------------- /math-primitives/clamping.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:nineveh.math-primitives) 2 | 3 | (defun-g-equiv saturate ((val :float)) 4 | (clamp val 0s0 1s0)) 5 | 6 | (defun-g-equiv saturate ((val :vec2)) 7 | (clamp val 0s0 1s0)) 8 | 9 | (defun-g-equiv saturate ((val :vec3)) 10 | (clamp val 0s0 1s0)) 11 | 12 | (defun-g-equiv saturate ((val :vec4)) 13 | (clamp val 0s0 1s0)) 14 | 15 | (defun-g-equiv saturate ((val :double) &context :410 :420 :430 :440 :450) 16 | (clamp val 0d0 1d0)) 17 | 18 | (defun-g-equiv saturate ((val :dvec2) &context :410 :420 :430 :440 :450) 19 | (clamp val 0d0 1d0)) 20 | 21 | (defun-g-equiv saturate ((val :dvec3) &context :410 :420 :430 :440 :450) 22 | (clamp val 0d0 1d0)) 23 | 24 | (defun-g-equiv saturate ((val :dvec4) &context :410 :420 :430 :440 :450) 25 | (clamp val 0d0 1d0)) 26 | -------------------------------------------------------------------------------- /math-primitives/mod.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.math-primitives) 2 | 3 | (v-defmacro mod-fixed-denominator (val denominator) 4 | (assert (and (or (integerp denominator) (typep denominator 'single-float)) 5 | (> denominator 0))) 6 | (let ((denom (float denominator))) 7 | (if (or (numberp val) (symbolp val)) 8 | `(- ,val (* (floor (* ,val (/ 1f0 ,denom))) ,denom)) 9 | (let ((gval (gensym "val"))) 10 | `(let ((,gval ,val)) 11 | (- ,gval (* (floor (* ,gval (/ 1f0 ,denom))) ,denom))))))) 12 | 13 | (v-defmacro mod-fixed-denominator-low-quality (val denominator) 14 | (assert (and (or (integerp denominator) (typep denominator 'single-float)) 15 | (> denominator 0))) 16 | (let ((denom (float denominator))) 17 | `(* (fract (* ,val (/ 1f0 ,denom))) ,denom))) 18 | -------------------------------------------------------------------------------- /textures/sampling.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.textures) 2 | 3 | (defun-g sample-equirectangular-tex ((tex :sampler-2d) (vec :vec3)) 4 | (let* ((vec (normalize vec)) 5 | (uv (v! (/ (atan (z vec) (x vec)) (* 2s0 +pi+)) 6 | (- (/ (+ (asin (y vec)) (/ +pi+ 2s0)) 7 | +pi+))))) 8 | (texture tex uv))) 9 | 10 | (defun-g uv->cube-map-directions ((uv :vec2)) 11 | (let ((scaled-uv (v! (* (- (x uv) 0.5) 2) 12 | (* (- (y uv) 0.5) 2 -1s0)))) 13 | (values 14 | (normalize (v! 1s0 (y scaled-uv) (- (x scaled-uv)))) 15 | (normalize (v! -1s0 (y scaled-uv) (x scaled-uv))) 16 | (normalize (v! (x scaled-uv) 1s0 (- (y scaled-uv)))) 17 | (normalize (v! (x scaled-uv) -1s0 (y scaled-uv))) 18 | (normalize (v! (x scaled-uv) (y scaled-uv) 1s0)) 19 | (normalize (v! (- (x scaled-uv)) (y scaled-uv) -1s0))))) 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Nineveh (WIP) 2 | 3 | Nineveh is a library of common gpu-functions and GL related helper functions. 4 | 5 | It is intended to act as a sort of standard library for gpu programming. 6 | 7 | It currently provides gpu functions for: 8 | - common math operations outside of the glsl spec 9 | - hashing 10 | - noise 11 | - color-space conversion 12 | - interoplation & misc curves 13 | - tonemapping 14 | - graphing 15 | - normal generation 16 | 17 | And CPU side functions for: 18 | - primitive mesh generation 19 | - cube-map & hdr texture loading 20 | - cube fbo helpers 21 | 22 | Amongst others 23 | 24 | ### Cloning 25 | 26 | Whilst it is recommended to get Nineveh from quicklisp, if you clone please note that `master` is not the stable branch. Please use `release-quicklisp` for the stable code that will be in the next Nineveh release. 27 | 28 | ### A thing! 29 | 30 | ![graphs](http://techsnuffle.com/assets/images/graphing0.png) 31 | -------------------------------------------------------------------------------- /distortion/distortion.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:nineveh.distortion) 2 | 3 | ;;------------------------------------------------------------ 4 | 5 | (defun-g radial-distort ((coord :vec2) (amount :vec2)) 6 | (let* ((cc (* (- coord 0.5) 2.0))) 7 | (+ coord (* cc amount)))) 8 | 9 | (defun-g barrel-distortion ((p :vec2) (amount :vec2)) 10 | (let* ((p (- (* 2.0 p) 1.0)) 11 | (max-barrel-power (sqrt 5.0)) 12 | (radius (dot p p)) 13 | (p (* p (pow (v2! radius) (* max-barrel-power amount))))) 14 | (+ (* p 0.5) 0.5))) 15 | 16 | (defun-g brown-conrady-distortion ((uv :vec2) (dist :float)) 17 | (let* ((uv (- (* uv 2.0) 1.0)) 18 | (barrel-distortion1 (* 0.1 dist)) 19 | (barrel-distortion2 (* -0.025 dist)) 20 | (r2 (dot uv uv)) 21 | (uv (* uv (+ 1.0 (+ (* barrel-distortion1 r2) 22 | (* barrel-distortion2 (* r2 r2))))))) 23 | (+ (* uv 0.5) 0.5))) 24 | 25 | ;;------------------------------------------------------------ 26 | -------------------------------------------------------------------------------- /internals/quad.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.internals) 2 | 3 | ;;------------------------------------------------------------ 4 | 5 | (defun make-gpu-quad () 6 | (make-buffer-stream 7 | (make-gpu-array 8 | (list (list (v! -0.5 0.5 0 0) (v! 0.0 1.0)) 9 | (list (v! -0.5 -0.5 0 0) (v! 0.0 0.0)) 10 | (list (v! 0.5 -0.5 0 0) (v! 1.0 0.0)) 11 | (list (v! -0.5 0.5 0 0) (v! 0.0 1.0)) 12 | (list (v! 0.5 -0.5 0 0) (v! 1.0 0.0)) 13 | (list (v! 0.5 0.5 0 0) (v! 1.0 1.0))) 14 | :element-type 'g-pt 15 | :dimensions 6) 16 | :retain-arrays t)) 17 | 18 | (defvar *quad-cache* 19 | (make-hash-table :test #'eq)) 20 | 21 | (defun get-quad-for-context (context) 22 | (or (gethash context *quad-cache*) 23 | (setf (gethash context *quad-cache*) 24 | (make-gpu-quad)))) 25 | 26 | (defun get-gpu-quad () 27 | (get-quad-for-context (cepl-context))) 28 | 29 | ;;------------------------------------------------------------ 30 | -------------------------------------------------------------------------------- /textures/cube-tex-fbos.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.textures) 2 | 3 | (defun cube-texture-p (texture) 4 | (and (texture-p texture) 5 | (eq (texture-type texture) :texture-cube-map))) 6 | 7 | (defun cube-faces (cube-texture &optional (level-num 0)) 8 | (assert (cube-texture-p cube-texture)) 9 | (loop :for face :below 6 :collect 10 | (texref cube-texture :mipmap-level level-num :cube-face face))) 11 | 12 | (defun make-fbos-for-each-mipmap-of-cube-texture (cube-texture 13 | &key (with-depth t)) 14 | (loop :for level :below (texture-mipmap-levels cube-texture) :collect 15 | (let* ((arrays (cube-faces cube-texture level)) 16 | (color-specs (loop :for x :in arrays :for i :from 0 :collect 17 | (list i x))) 18 | (spec (append color-specs 19 | (when with-depth 20 | `((:d :dimensions ,(dimensions (first arrays)))))))) 21 | 22 | (apply #'make-fbo spec)))) 23 | -------------------------------------------------------------------------------- /math-primitives/vmax.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.math-primitives) 2 | 3 | ;;------------------------------------------------------------ 4 | 5 | (defun-g vmax ((vec :vec2)) 6 | "Returns the `max` of the vectors components" 7 | (max (x vec) (y vec))) 8 | 9 | (defun-g vmax ((vec :vec3)) 10 | "Returns the `max` of the vectors components" 11 | (max (x vec) (y vec) (z vec))) 12 | 13 | (defun-g vmax ((vec :vec4)) 14 | "Returns the `max` of the vectors components" 15 | (max (x vec) (y vec) (z vec) (w vec))) 16 | 17 | ;;------------------------------------------------------------ 18 | 19 | (defun-g vmin ((vec :vec2)) 20 | "Returns the `min` of the vectors components" 21 | (min (x vec) (y vec))) 22 | 23 | (defun-g vmin ((vec :vec3)) 24 | "Returns the `min` of the vectors components" 25 | (min (x vec) (y vec) (z vec))) 26 | 27 | (defun-g vmin ((vec :vec4)) 28 | "Returns the `min` of the vectors components" 29 | (min (x vec) (y vec) (z vec) (w vec))) 30 | 31 | ;;------------------------------------------------------------ 32 | -------------------------------------------------------------------------------- /random/docs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.random) 2 | 3 | (docs:define-docs 4 | (defun rand 5 | " 6 | -- Arg -- 7 | 8 | seed :vec2 9 | 10 | -- Purpose -- 11 | 12 | Returns a 'random' float. 13 | 14 | -- Explaination -- 15 | 16 | Based on the fact that sin(*x) 17 | modulates extremely quickly. So quickly that sampling the sin 18 | function at every fragment location effectively gives you “random” 19 | numbers 20 | 21 | -- Notes -- 22 | 23 | This could have issues on some ES/WebGL implementations. Some implementations 24 | might not be preconditioning sin to a reasonable 2PI range. This has been shown 25 | to cause issues before. 26 | 27 | At the time of writing Varjo does not support float precision declarations but 28 | when it does we can provide a safer implementation of this 29 | 30 | -- Credit -- 31 | 32 | Impementation - Unknown but see this possible answer: 33 | http://stackoverflow.com/a/34223787/574033 34 | 35 | Notes - http://byteblacksmith.com/improvements-to-the-canonical-one-liner-glsl-rand-for-opengl-es-2-0/")) 36 | -------------------------------------------------------------------------------- /vignette/vignette.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.vignette) 2 | 3 | ;;------------------------------------------------------------ 4 | 5 | (defun-g vignette ((uv :vec2) 6 | (intensity :float) 7 | (extent :float)) 8 | (let* ((uv (* uv (- 1.0 (s~ uv :yx)))) 9 | (vig0 (* (x uv) (y uv) intensity)) 10 | (vig1 (expt vig0 extent))) 11 | vig1)) 12 | 13 | (defun-g vignette ((uv :vec2)) 14 | (vignette uv 15.0 0.25)) 15 | 16 | ;;------------------------------------------------------------ 17 | 18 | (defun-g natural-vignette ((uv :vec2) 19 | (aspect-ratio :float) 20 | (falloff :float)) 21 | (let* ((coord (* (- uv 0.5) 22 | aspect-ratio 23 | 2.0)) 24 | (rf (* (length coord) falloff)) 25 | (rf2-1 (+ (* rf rf) 1.0))) 26 | (/ 1f0 (* rf2-1 rf2-1)))) 27 | 28 | (defun-g natural-vignette ((uv :vec2) 29 | (aspect-ratio :float)) 30 | (natural-vignette uv aspect-ratio 0.5)) 31 | 32 | ;;------------------------------------------------------------ 33 | -------------------------------------------------------------------------------- /math-primitives/radical-inverse.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.math-primitives) 2 | 3 | (defun-g radical-inverse-vdc ((bits :uint)) 4 | "Given a uint (e.g 5) it takes the binary representation of the 5 | number (0101.0) and mirrors it the decimal (0.1010) and 6 | returns it as a float (0.625) 7 | 8 | vdc stand for Van Der Corput. For more details see: 9 | http://holger.dammertz.org/stuff/notes_HammersleyOnHemisphere.html" 10 | (let* ((bits (logior (<< bits (uint 16)) (>> bits (uint 16)))) 11 | (bits (logior (<< (logand bits (uint #x55555555)) (uint 1)) 12 | (>> (logand bits (uint #xAAAAAAAA)) (uint 1)))) 13 | (bits (logior (<< (logand bits (uint #x33333333)) (uint 2)) 14 | (>> (logand bits (uint #xCCCCCCCC)) (uint 2)))) 15 | (bits (logior (<< (logand bits (uint #x0F0F0F0F)) (uint 4)) 16 | (>> (logand bits (uint #xF0F0F0F0)) (uint 4)))) 17 | (bits (logior (<< (logand bits (uint #x00FF00FF)) (uint 8)) 18 | (>> (logand bits (uint #xFF00FF00)) (uint 8))))) 19 | ;; ↓ 0x100000000 as a float ↓ 20 | (* (float bits) (glsl-expr "2.3283064365386963e-10" :float)))) 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Baggers 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /noise/simplex-helpers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.noise) 2 | 3 | (defun-g simplex-3d-get-corner-vectors ((p :vec3)) 4 | (let* ((skew-factor (v3! (/ 1.0 3.0))) 5 | (unskew-factor (v3! (/ 1.0 6.0))) 6 | (simplex-corner-pos (v3! 0.5)) 7 | (simplex-pyramid-height (v3! 0.7071068))) 8 | (multf p simplex-pyramid-height) 9 | (let* ((pi (floor (+ p (v3! (dot p skew-factor))))) 10 | (x0 (+ (- p pi) (v3! (dot pi unskew-factor)))) 11 | (g (step (s~ x0 :yzx) (s~ x0 :xyz))) 12 | (l (- (v3! 1.0) g)) 13 | (pi-1 (min (s~ g :xyz) (s~ l :zxy))) 14 | (pi-2 (max (s~ g :xyz) (s~ l :zxy))) 15 | (x1 (- (+ x0 pi-1) unskew-factor)) 16 | (x2 (- (+ x0 pi-2) skew-factor)) 17 | (x3 (- x0 simplex-corner-pos)) 18 | (v1234-x (v4! (x x0) (x x1) (x x2) (x x3))) 19 | (v1234-y (v4! (y x0) (y x1) (y x2) (y x3))) 20 | (v1234-z (v4! (z x0) (z x1) (z x2) (z x3)))) 21 | (values pi pi-1 pi-2 v1234-x v1234-y v1234-z)))) 22 | 23 | (defun-g simplex-3d-get-surflet-weights ((v1234-x :vec4) 24 | (v1234-y :vec4) 25 | (v1234-z :vec4)) 26 | (let* ((surflet-weights (+ (* v1234-x v1234-x) 27 | (+ (* v1234-y v1234-y) 28 | (* v1234-z v1234-z))))) 29 | (setf surflet-weights (max (- (v4! 0.5) surflet-weights) 0.0)) 30 | (* surflet-weights (* surflet-weights surflet-weights)))) 31 | -------------------------------------------------------------------------------- /math-primitives/docs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.math-primitives) 2 | 3 | (docs:define-docs 4 | (defmacro mod-fixed-denominator 5 | " 6 | -- Args -- 7 | 8 | val - a form (should evaluate to a :float) 9 | 10 | denominator - a constant float or integer 11 | 12 | -- Purpose -- 13 | 14 | This macro emits an implementation of mod with a fixed denominator in a form 15 | that shader compilers can trivially optimize away the divide. 16 | 17 | It is very likely that your implmentation performs with optimization for mod 18 | anyway. However some may recommend doing it anyway. 19 | 20 | -- Credit -- 21 | 22 | Marc Olano - http://www.cs.umbc.edu/%7Eolano/papers/index.html#mNoise 23 | 24 | Brian Sharpe - For his excellent explanations here ↓ 25 | https://briansharpe.wordpress.com/2011/10/01/gpu-texture-free-noise/") 26 | 27 | (defmacro mod-fixed-denominator-low-quality 28 | " 29 | -- Args -- 30 | 31 | val - a form (should evaluate to a :float) 32 | 33 | denominator - a constant float or integer 34 | 35 | -- Purpose -- 36 | 37 | Like the regular mod-fixed-denominator macro, this macro emits an 38 | implementation of mod with a fixed denominator in a form that shader compilers 39 | can trivially optimize away the divide..HOWEVER it is also faster and lower 40 | quality (it suffers from precision provlems). 41 | 42 | It is very likely that your implmentation performs with optimization for mod 43 | anyway. However some may recommend doing it anyway. 44 | 45 | -- Credit -- 46 | 47 | Brian Sharpe - https://briansharpe.wordpress.com/2011/10/01/gpu-texture-free-noise/")) 48 | -------------------------------------------------------------------------------- /color/sets.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.color) 2 | 3 | (defvar *boytons-11-rarely-confused-colors* 4 | (list (v! 0.0 0.0 1.0) ;;Blue 5 | (v! 1.0 0.0 0.0) ;;Red 6 | (v! 0.0 1.0 0.0) ;;Green 7 | (v! 1.0 1.0 0.0) ;;Yellow 8 | (v! 1.0 0.0 1.0) ;;Magenta 9 | (v! 1.0 0.5019608 0.5019608) ;;Pink 10 | (v! 0.5019608 0.5019608 0.5019608) ;;Gray 11 | (v! 0.5019608 0.0 0.0) ;;Brown 12 | (v! 1.0 0.5019608 0.0))) ;;Orange 13 | 14 | (defvar *kellys-max-contrast-colors* 15 | (list (v! 1.0 0.7019608 0.0) ;;Vivid Yellow 16 | (v! 0.5019608 0.24313727 0.45882356) ;;Strong Purple 17 | (v! 1.0 0.40784317 0.0) ;;Vivid Orange 18 | (v! 0.6509804 0.7411765 0.8431373) ;;Very Light Blue 19 | (v! 0.7568628 0.0 0.1254902) ;;Vivid Red 20 | (v! 0.8078432 0.63529414 0.38431376) ;;Grayish Yellow 21 | (v! 0.5058824 0.43921572 0.40000004) ;;Medium Gray 22 | 23 | ;;The following will not be good for people with defective color vision 24 | (v! 0.0 0.4901961 0.20392159) ;;Vivid Green 25 | (v! 0.96470594 0.46274513 0.5568628) ;;Strong Purplish Pink 26 | (v! 0.0 0.3254902 0.5411765) ;;Strong Blue 27 | (v! 1.0 0.4784314 0.36078432) ;;Strong Yellowish Pink 28 | (v! 0.3254902 0.21568629 0.4784314) ;;Strong Violet 29 | (v! 1.0 0.5568628 0.0) ;;Vivid Orange Yellow 30 | (v! 0.7019608 0.15686275 0.31764707) ;;Strong Purplish Red 31 | (v! 0.9568628 0.7843138 0.0) ;;Vivid Greenish Yellow 32 | (v! 0.49803925 0.09411766 0.050980397) ;;Strong Reddish Brown 33 | (v! 0.5764706 0.6666667 0.0) ;;Vivid Yellowish Green 34 | (v! 0.34901962 0.20000002 0.08235294) ;;Deep Yellowish Brown 35 | (v! 0.9450981 0.227451 0.07450981) ;;Vivid Reddish Orange 36 | (v! 0.13725491 0.17254902 0.08627451))) ;;Dark Olive Green 37 | -------------------------------------------------------------------------------- /graphing/plot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.graphing) 2 | 3 | (defun-g plot ((val :float) 4 | (uv :vec2) 5 | (xy-range :vec4) ;; x-min x-max y-min y-max 6 | (line-style :vec4) 7 | (axis-style :vec4)) 8 | (let* (;; 9 | (line-thickness (w line-style)) 10 | (line-color (v! (s~ line-style :xyz) 1)) 11 | ;; 12 | (axis-thickness (* 0.5 (w axis-style))) 13 | (axis-color (v! (s~ axis-style :xyz) 1)) 14 | ;; 15 | (pval (* (- (smoothstep (- val line-thickness) val (y uv)) 16 | (smoothstep val (+ val line-thickness) (y uv))) 17 | line-color)) 18 | ;; 19 | (x-diff (- (y xy-range) (x xy-range))) 20 | (y-diff (- (w xy-range) (z xy-range))) 21 | ;; 22 | (uv (+ (* uv (v! x-diff y-diff)) 23 | (s~ xy-range :xz)))) 24 | (+ pval 25 | (* axis-color (smoothstep (* axis-thickness x-diff) 0 (abs (x uv)))) 26 | (* axis-color (smoothstep (* axis-thickness y-diff) 0 (abs (y uv))))))) 27 | 28 | ;;------------------------------------------------------------ 29 | 30 | (defun-g plot ((val :float) 31 | (uv :vec2) 32 | (xy-range :vec4) ;; x-min x-max y-min y-max 33 | (line-style :vec4)) 34 | (plot val uv xy-range line-style (v! 0.1 0.1 0.1 0.004))) 35 | 36 | ;;------------------------------------------------------------ 37 | 38 | (defun-g plot ((val :float) 39 | (uv :vec2) 40 | (xy-range :vec4)) ;; x-min x-max y-min y-max 41 | (plot val uv xy-range (v! 1 1 1 0.004) (v! 0.1 0.1 0.1 0.004))) 42 | 43 | ;;------------------------------------------------------------ 44 | 45 | (defun-g plot ((val :float) 46 | (uv :vec2)) 47 | (plot val 48 | uv 49 | (v! 0 1 0 1) ;; range 50 | (v! 1 1 1 0.004) ;; line-style 51 | (v! 0.1 0.1 0.1 0.004))) ;; axis-style 52 | -------------------------------------------------------------------------------- /math-primitives/remap.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:nineveh.math-primitives) 2 | 3 | ;;------------------------------------------------------------ 4 | ;; Remap 5 | 6 | (defun-g remap ((val :float) 7 | (original-min :float) (original-max :float) 8 | (new-min :float) (new-max :float)) 9 | (+ new-min 10 | (* (- val original-min) 11 | (/ (- new-max new-min) 12 | (- original-max original-min))))) 13 | 14 | (defun-g remap ((val :vec2) 15 | (original-min :vec2) (original-max :vec2) 16 | (new-min :vec2) (new-max :vec2)) 17 | (+ new-min 18 | (* (- val original-min) 19 | (/ (- new-max new-min) 20 | (- original-max original-min))))) 21 | 22 | (defun-g remap ((val :vec3) 23 | (original-min :vec3) (original-max :vec3) 24 | (new-min :vec3) (new-max :vec3)) 25 | (+ new-min 26 | (* (- val original-min) 27 | (/ (- new-max new-min) 28 | (- original-max original-min))))) 29 | 30 | (defun-g remap ((val :vec4) 31 | (original-min :vec4) (original-max :vec4) 32 | (new-min :vec4) (new-max :vec4)) 33 | (+ new-min 34 | (* (- val original-min) 35 | (/ (- new-max new-min) 36 | (- original-max original-min))))) 37 | 38 | ;;------------------------------------------------------------ 39 | ;; Remap Vec Ranges 40 | 41 | (defun-g remap ((val :float) (original-range :vec2) (new-range :vec2)) 42 | (+ (x new-range) 43 | (* (- val (x original-range)) 44 | (/ (- (y new-range) (x new-range)) 45 | (- (y original-range) (x original-range)))))) 46 | 47 | (defun-g remap ((val :vec2) (original-range :vec4) (new-range :vec4)) 48 | (+ (s~ new-range :xz) 49 | (* (- val (s~ original-range :xz)) 50 | (/ (- (s~ new-range :yw) (s~ new-range :xz)) 51 | (- (s~ original-range :yw) (s~ original-range :xz)))))) 52 | 53 | (defun-g remap-uv ((uv :vec2) (range :vec4)) 54 | (+ (* uv (- (s~ range :yw) (s~ range :xz))) 55 | (s~ range :xz))) 56 | -------------------------------------------------------------------------------- /graphing/simple.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.graphing) 2 | 3 | ;; Based on Mikael Hvidtfeldt Christensen's excellent article here: 4 | ;; http://blog.hvidtfeldts.net/index.php/2011/07/plotting-high-frequency-functions-using-a-gpu/ 5 | ;; 6 | ;; We don't use dithering on this version 7 | 8 | ;; {TODO} When inlining is implemented in Varjo make the implementation of this 9 | ;; function: (graph func pos line-thickness 10) 10 | 11 | (defun-g graph ((func (function (:float) :float)) 12 | (pos :vec2) 13 | (line-thickness :float)) 14 | ;; Usage 15 | ;; (v3! (graph #'cos uv 0.005)) 16 | (let* ((samples 10) 17 | (samples (float samples)) 18 | (max-dist (v2! line-thickness)) 19 | (step (/ max-dist (v2! samples))) 20 | (count 0f0) 21 | (initial-offset (* step samples -0.5)) 22 | (my-samples 0f0)) 23 | (incf initial-offset pos) 24 | (for (i 0f0) (< i samples) (++ i) 25 | (let ((fx (funcall func (+ (x pos) (* i (x step)))))) 26 | (for (j 0f0) (< j samples) (++ j) 27 | (when (> (+ (* i i) (* j j)) (* samples samples)) 28 | (continue)) 29 | (incf my-samples 1f0) 30 | (let ((diff (- fx (+ (y pos) (* j (y step)))))) 31 | (incf count (- (* (step 0f0 diff) 2f0) 1)))))) 32 | (if (/= (abs count) my-samples) 33 | (- 1f0 (/ (abs (float count)) (float my-samples))) 34 | 0f0))) 35 | 36 | (defun-g graph ((func (function (:float) :float)) 37 | (pos :vec2) 38 | (line-thickness :float) 39 | (samples :int)) 40 | ;; Usage 41 | ;; (v3! (graph #'cos uv 0.005 50)) 42 | (let* ((samples (float samples)) 43 | (max-dist (v2! line-thickness)) 44 | (step (/ max-dist (v2! samples))) 45 | (count 0f0) 46 | (initial-offset (* step samples -0.5)) 47 | (my-samples 0f0)) 48 | (incf initial-offset pos) 49 | (for (i 0f0) (< i samples) (++ i) 50 | (let ((fx (funcall func (+ (x pos) (* i (x step)))))) 51 | (for (j 0f0) (< j samples) (++ j) 52 | (when (> (+ (* i i) (* j j)) (* samples samples)) 53 | (continue)) 54 | (incf my-samples 1f0) 55 | (let ((diff (- fx (+ (y pos) (* j (y step)))))) 56 | (incf count (- (* (step 0f0 diff) 2f0) 1)))))) 57 | (if (/= (abs count) my-samples) 58 | (- 1f0 (/ (abs (float count)) (float my-samples))) 59 | 0f0))) 60 | -------------------------------------------------------------------------------- /color/luminance.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.color) 2 | 3 | ;;------------------------------------------------------------ 4 | ;; All props to: 5 | ;; - Franci Penov: Whos stackoverflow answers provided the bulk of 6 | ;; functions here 7 | ;; - Maarten: Whos shadertoy code showed how to apply luminance 8 | ;;------------------------------------------------------------ 9 | 10 | ;; Photometric/digital ITU BT.709: http://www.itu.int/rec/R-REC-BT.709 11 | ;; https://en.wikipedia.org/wiki/Luminance_%28relative%29 12 | (defun-g rgb->luma-bt709 ((color :vec3)) 13 | (dot color (vec3 "0.2126" "0.7152" "0.0722"))) 14 | 15 | (defun-g rgb->luma-bt709 ((color :vec4)) 16 | (dot (s~ color :xyz) (vec3 "0.2126" "0.7152" "0.0722"))) 17 | 18 | ;; Y = 0.2126 R + 0.7152 G + 0.0722 B 19 | 20 | ;; Digital ITU BT.601 (gives more weight to the R and B components): 21 | (defun-g rgb->luma-bt601 ((color :vec3)) 22 | (dot color (vec3 "0.299" "0.587" "0.114"))) 23 | 24 | (defun-g rgb->luma-bt601 ((color :vec4)) 25 | (dot (s~ color :xyz) (vec3 "0.299" "0.587" "0.114"))) 26 | 27 | ;; If you are willing to trade accuracy for perfomance, there are two 28 | ;; approximation formulas for this one: 29 | 30 | (defun-g rgb->luma-low-accuracy-0 ((color :vec3)) 31 | ;; Y = 0.33 R + 0.5 G + 0.16 B 32 | (/ (+ (x color) (x color) 33 | (y color) 34 | (z color) (z color) (z color)) 35 | 6)) 36 | 37 | (defun-g rgb->luma-low-accuracy-0 ((color :vec4)) 38 | ;; Y = 0.33 R + 0.5 G + 0.16 B 39 | (/ (+ (x color) (x color) 40 | (y color) 41 | (z color) (z color) (z color)) 42 | 6)) 43 | 44 | ;; (defun-g rgb->luma-low-accuracy-1 ((color :vec3)) 45 | ;; ;; Y = 0.375 R + 0.5 G + 0.125 B 46 | ;; (>> (+ (x color) (x color) (x color) 47 | ;; (y color) 48 | ;; (z color) (z color) (z color) (z color)) 49 | ;; 3)) 50 | 51 | ;; (defun-g rgb->luma-low-accuracy-1 ((color :vec4)) 52 | ;; ;; Y = 0.375 R + 0.5 G + 0.125 B 53 | ;; (>> (+ (x color) (x color) (x color) 54 | ;; (y color) 55 | ;; (z color) (z color) (z color) (z color)) 56 | ;; 3)) 57 | 58 | (defun-g apply-luminance ((lum-function (function (:vec3) :float)) 59 | (lum :float) 60 | (color :vec3)) 61 | (let ((lum (/ lum (funcall lum-function color)))) 62 | (* color lum))) 63 | 64 | (defun-g apply-luminance ((lum-function (function (:vec4) :float)) 65 | (lum :float) 66 | (color :vec4)) 67 | (let ((lum (/ lum (funcall lum-function color)))) 68 | (* color lum))) 69 | -------------------------------------------------------------------------------- /hashing/blum-blum-shub-hash.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.hashing) 2 | 3 | ;;------------------------------------------------------------ 4 | 5 | (defun-g bbs-coord-prepare ((x :vec4)) 6 | (mod-fixed-denominator x 61f0)) 7 | 8 | (defun-g bbs-coord-prepare ((x :vec3)) 9 | (mod-fixed-denominator x 61f0)) 10 | 11 | (defun-g bbs-permute ((x :vec4)) 12 | (mod-fixed-denominator-low-quality (* x x) 61f0)) 13 | 14 | (defun-g bbs-permute-and-resolve ((x :vec4)) 15 | (fract (* x x (/ 1.0 61.0)))) 16 | 17 | ;;------------------------------------------------------------ 18 | ;; 2D 19 | 20 | (defun-g blum-blum-shub-hash ((grid-cell :vec2)) 21 | (let* ((hash-coord 22 | (bbs-coord-prepare 23 | (v! (s~ grid-cell :xy) (+ (s~ grid-cell :xy) (v2! 1.0))))) 24 | (p (bbs-permute (s~ hash-coord :xzxz)))) 25 | ;; This second permute is not in the original paper but it lessens the 26 | ;; worst artifacts 27 | ;; ↓↓↓↓ 28 | (setf p (bbs-permute (+ p (s~ hash-coord :yyww)))) 29 | (bbs-permute-and-resolve (+ p (s~ hash-coord :xzxz))))) 30 | 31 | (defun-g blum-blum-shub-hash-low-quality ((grid-cell :vec2)) 32 | ;; impl from the original paper, we now prefer #'blum-blum-shub-hash-2d 33 | ;; as the extra permute reduces some of the nastier artifacts we were 34 | ;; seeing with this version. 35 | (let* ((hash-coord 36 | (bbs-coord-prepare 37 | (v! (s~ grid-cell :xy) (+ (s~ grid-cell :xy) (v2! 1.0))))) 38 | (p (bbs-permute (s~ hash-coord :xzxz)))) 39 | (bbs-permute-and-resolve (+ p (s~ hash-coord :yyww))))) 40 | 41 | ;;------------------------------------------------------------ 42 | ;; 3D 43 | 44 | 45 | (defun-g blum-blum-shub-hash ((grid-cell :vec3)) 46 | (let (((lowz-hash :vec4)) 47 | ((highz-hash :vec4)) 48 | (domain 60.0)) 49 | (setf (s~ grid-cell :xyz) 50 | (- (s~ grid-cell :xyz) 51 | (* (floor (* (s~ grid-cell :xyz) (/ 1.0 domain))) domain))) 52 | (let* ((grid-cell-inc1 (* (step grid-cell (v3! (- domain 1.5))) 53 | (+ grid-cell (v3! 1.0)))) 54 | (p (bbs-permute (s~ (v2! (x grid-cell) (x grid-cell-inc1)) :xyxy)))) 55 | (setf p 56 | (bbs-permute 57 | (+ p (s~ (v2! (y grid-cell) (y grid-cell-inc1)) :xxyy)))) 58 | (setf lowz-hash (bbs-permute-and-resolve (+ p (s~ grid-cell :zzzz)))) 59 | (setf highz-hash 60 | (bbs-permute-and-resolve (+ p (s~ grid-cell-inc1 :zzzz))))) 61 | (values lowz-hash highz-hash))) 62 | 63 | ;;------------------------------------------------------------ 64 | -------------------------------------------------------------------------------- /noise/value-noise.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.noise) 2 | 3 | ;;------------------------------------------------------------ 4 | ;; 2D 5 | 6 | (defun-g value-noise ((p :vec2)) 7 | (let* ((pi (floor p)) 8 | (pf (- p pi)) 9 | (hash (bs-fast32-hash pi)) 10 | (blend (quintic pf)) 11 | (blend2 (v! blend (- (v2! 1.0) blend)))) 12 | (dot hash (* (s~ blend2 :zxzx) (s~ blend2 :wwyy))))) 13 | 14 | (defun-g value-noise-deriv ((p :vec2)) 15 | (let* ((pi (floor p)) 16 | (pf (- p pi)) 17 | (hash (bs-fast32-hash pi)) 18 | (blend (quintic-interp-and-deriv pf)) 19 | (res0 (mix (s~ hash :xyxz) (s~ hash :zwyw) (s~ blend :yyxx)))) 20 | (+ (v3! (x res0) 0.0 0.0) 21 | (* (- (s~ res0 :yyw) (s~ res0 :xxz)) (s~ blend :xzw))))) 22 | 23 | ;;------------------------------------------------------------ 24 | ;; 3D 25 | 26 | (defun-g value-noise ((p :vec3)) 27 | (let* ((pi (floor p)) 28 | (pf (- p pi))) 29 | (multiple-value-bind (hash-lowz hash-highz) (bs-fast32-hash pi) 30 | (let* ((blend (quintic pf)) 31 | (res0 (mix hash-lowz hash-highz (z blend))) 32 | (blend2 (v! (s~ blend :xy) (- (v2! 1.0) (s~ blend :xy))))) 33 | (dot res0 (* (s~ blend2 :zxzx) (s~ blend2 :wwyy))))))) 34 | 35 | (defun-g value-noise-deriv ((p :vec3)) 36 | (let* ((pi (floor p)) 37 | (pf (- p pi))) 38 | (multiple-value-bind (hash-lowz hash-highz) 39 | (bs-fast32-hash pi) 40 | (let* ((blend (quintic pf)) 41 | (res0 (mix hash-lowz hash-highz (z blend))) 42 | (res1 (mix (s~ res0 :xyxz) (s~ res0 :zwyw) (s~ blend :yyxx))) 43 | (res3 44 | (mix (v! (s~ hash-lowz :xy) (s~ hash-highz :xy)) 45 | (v! (s~ hash-lowz :zw) (s~ hash-highz :zw)) (y blend))) 46 | (res4 (mix (s~ res3 :xz) (s~ res3 :yw) (x blend)))) 47 | (+ (v4! (x res1) 0.0 0.0 0.0) 48 | (* (- (v! (s~ res1 :yyw) (y res4)) 49 | (v! (s~ res1 :xxz) (x res4))) 50 | (v! (x blend) (quintic-deriv pf)))))))) 51 | 52 | ;;------------------------------------------------------------ 53 | ;; 4D 54 | 55 | (defun-g value-noise ((p :vec4)) 56 | (let* ((pi (floor p)) 57 | (pf (- p pi))) 58 | (multiple-value-bind (z0w0-hash z1w0-hash z0w1-hash z1w1-hash) 59 | (bs-quick32-hash pi) 60 | (let* ((blend (quintic pf)) 61 | (res0 (+ z0w0-hash (* (- z0w1-hash z0w0-hash) (s~ blend :wwww)))) 62 | (res1 (+ z1w0-hash (* (- z1w1-hash z1w0-hash) (s~ blend :wwww))))) 63 | (setf res0 (+ res0 (* (- res1 res0) (s~ blend :zzzz)))) 64 | (setf (s~ blend :zw) (- (v2! 1.0) (s~ blend :xy))) 65 | (dot res0 (* (s~ blend :zxzx) (s~ blend :wwyy))))))) 66 | -------------------------------------------------------------------------------- /shaping-functions/to-sort.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.shaping-functions) 2 | 3 | (defun-g almost-identity ((threshold :float) (min :float) (x :float)) 4 | "Acts as identity above whilst x is above 'threshold' below this is smooths 5 | off to 'min' 6 | 7 | Valid when x>=0 8 | 9 | Credit: 10 | IQ 11 | http://www.iquilezles.org/www/articles/functions/functions.htm" 12 | (if (> x threshold) 13 | x 14 | (let* ((a (- (* 2f0 min) threshold)) 15 | (b (- (* 2f0 threshold) (* 3f0 min))) 16 | (r (/ x threshold))) 17 | (+ (* r r (+ (* a r) b)) 18 | min)))) 19 | 20 | (defun-g impulse ((squash :float) (x :float)) 21 | "Grows fast to 1f0 and then slowly decays. Use 'squash' to control the 22 | squashing/stretching of the function. 23 | 24 | Note: It reaches 1f0 (its peak) at exactly x=1/squash. Thus higher 25 | squash values shorten the 'distance' to the curve peak 26 | 27 | Credit: 28 | IQ 29 | http://www.iquilezles.org/www/articles/functions/functions.htm" 30 | (let ((h (* squash x))) 31 | (* h (exp (- 1f0 h))))) 32 | 33 | (defun-g cubic-pulse ((center :float) (half-width :float) (x :float)) 34 | "A curve centered on 'center' (where y=1), where the length of the curve to 35 | y=0 is 'width'. 36 | 37 | Cheap replacement for a gaussian 38 | 39 | Credit: 40 | IQ 41 | http://www.iquilezles.org/www/articles/functions/functions.htm" 42 | (let ((x (abs (- x center)))) 43 | (if (> x half-width) 44 | 0f0 45 | (let ((x (/ x half-width))) 46 | (- 1f0 (* x x (- 3f0 (* 2f0 x)))))))) 47 | 48 | (defun-g exponential-step ((k :float) (exponent :float) (x :float)) 49 | "A smoothstep with a control on sharpness 50 | 51 | Credit: 52 | IQ 53 | http://www.iquilezles.org/www/articles/functions/functions.htm" 54 | ;; {TODO} I'd like a better name for 'k' 55 | (exp (* (pow x exponent) (- k)))) 56 | 57 | (defun-g parabola ((k :float) (x :float)) 58 | "Remaps the 0..1 interval into 0..1, such that the corners are remapped to 0 59 | and the center to 1. 60 | 61 | Credit: 62 | IQ 63 | http://www.iquilezles.org/www/articles/functions/functions.htm" 64 | ;; {TODO} I'd like better name for 'k' 65 | (pow (* 4f0 x (- 1f0 x)) k)) 66 | 67 | (defun-g power-curve ((a :float) (b :float) (x :float)) 68 | "Remaps the 0..1 interval into 0..1 such that the corners are remapped to 0 69 | and the point the curve reaches 1 is controllable via 'a' & 'b' 70 | 71 | Credit: 72 | IQ 73 | http://www.iquilezles.org/www/articles/functions/functions.htm" 74 | ;; {TODO} I'd like better names for 'a' & 'b' 75 | (let ((k (/ (pow (+ a b) (+ a b)) 76 | (* (pow a a) (pow b b))))) 77 | (* k (pow x a) (pow (- 1f0 x) b)))) 78 | 79 | (defun-g inverse-square ((x :float)) 80 | (/ 1f0 (* x x))) 81 | -------------------------------------------------------------------------------- /tonemapping/operators.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:nineveh.tonemapping) 2 | 3 | ;; Filmic Tonemapping Operators 4 | ;; 5 | ;; Please see here http://filmicworlds.com/blog/filmic-tonemapping-operators/ for excellent explanations 6 | ;; of the behaviours of the following 7 | ;; 8 | 9 | ;; Linear 10 | (defun-g tone-map-linear ((color :vec3) (exposure :float)) 11 | (let ((col (* color exposure))) 12 | (pow col (v3! (/ 1 2.2))))) 13 | 14 | ;; Reinhard 15 | (defun-g tone-map-reinhard ((color :vec3) (exposure :float)) 16 | (let* ((col (* color exposure)) 17 | (r (/ col (+ (v3! 1) col)))) 18 | (pow r (v3! (/ 1 2.2))))) 19 | 20 | ;; haarm-peter-duiker 21 | ;; The texture film-lut refers to this TGA file: 22 | ;; http://filmicgames.com/Downloads/FilmicTonemapping/FilmLut.tga 23 | ;; No pow(1/2.2) necessary. 24 | (defun-g tone-map-haarm-peter-duiker ((color :vec3) (exposure :float) 25 | &uniform (film-lut :sampler-2d)) 26 | (let* ((col (* color exposure)) 27 | (ld (v3! 0.002)) 28 | (lin-reference 0.18) 29 | (log-reference 444) 30 | (log-gamma 0.45) 31 | (log-color (/ (+ (* (/ (log10 (* 0.4 (/ col lin-Reference))) 32 | ld) 33 | log-gamma) 34 | (v3! log-reference)) 35 | 1023s0)) 36 | (clamped-log-col (max (v3! 0) (min (v3! 1) log-color))) 37 | (film-lut-width 256.0) 38 | (padding (/ 0.5 film-lut-width)) 39 | (r-coord (v! (mix padding (- 1 padding) (x log-color)) 0.5)) 40 | (g-coord (v! (mix padding (- 1 padding) (y log-color)) 0.5)) 41 | (b-coord (v! (mix padding (- 1 padding) (z log-color)) 0.5))) 42 | (v! (x (texture film-lut r-coord)) 43 | (x (texture film-lut g-coord)) 44 | (x (texture film-lut b-coord))))) 45 | 46 | ;; Jim Hejl and Richard Burgess-Dawson. 47 | ;; No pow(1/2.2) necessary. 48 | (defun-g tone-map-hejl-burgess-dawson ((color :vec3) (exposure :float)) 49 | (let* ((col (* color exposure)) 50 | (x (max (v3! 0) (- col (v3! 0.004))))) 51 | (/ (* x (+ (* 6.2 x) (v3! 0.5))) 52 | (+ (* x (+ (* 6.2 x) (v3! 1.7))) (v3! 0.06))))) 53 | 54 | ;; Uncharted 2 operator (John Hable) 55 | (defun-g tone-map-uncharted2 ((color :vec3) (exposure :float) 56 | (exposure-bias :float)) 57 | (let ((a 0.15) 58 | (b 0.50) 59 | (c 0.10) 60 | (d 0.20) 61 | (e 0.02) 62 | (f 0.30) 63 | (w 11.2)) 64 | (labels ((u2-tonemap ((x :vec3)) 65 | (- (/ (+ (* x (+ (* a x) (v3! (* c b)))) 66 | (v3! (* d e))) 67 | (+ (* x (+ (* a x) (v3! b))) 68 | (v3! (* d f)))) 69 | (v3! (/ e f))))) 70 | (let* ((col (* color exposure)) 71 | (curr (u2-tonemap (* exposure-bias col))) 72 | (lin-col (* curr (/ (v3! 1) (u2-tonemap (v3! w)))))) 73 | (pow lin-col (v3! (/ 1 2.2))))))) 74 | -------------------------------------------------------------------------------- /misc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh) 2 | 3 | (defmacro as-frame (&body body) 4 | `(progn 5 | (clear) 6 | (prog1 (progn ,@body) 7 | (swap)))) 8 | 9 | (defmacro def-simple-main-loop (name (&key on-start) &body body) 10 | `(define-simple-main-loop ,name (:on-start ,on-start) ,@body)) 11 | 12 | (defmacro define-simple-main-loop (name (&key on-start) &body body) 13 | (let ((frame-var-name (symb :* name :-frame-counter*)) 14 | (step-func-name (symb :% name :-step-func*))) 15 | `(progn 16 | (defvar ,frame-var-name 0) 17 | (defun ,name (action &optional frames) 18 | (ecase action 19 | (:start 20 | (if (= ,frame-var-name 0) 21 | (progn 22 | (setf ,frame-var-name (or frames -1)) 23 | (format t "~%- starting ~a -" ',name) 24 | (unwind-protect 25 | (progn 26 | (when (cepl.lifecycle:uninitialized-p) 27 | (cepl:repl)) 28 | (let ((on-start ,on-start)) 29 | (when on-start 30 | (funcall on-start))) 31 | (loop :until (= ,frame-var-name 0) :do 32 | (progn 33 | (decf ,frame-var-name 1) 34 | ;; update swank 35 | (livesupport:continuable 36 | (livesupport:update-repl-link)) 37 | ;; update event system 38 | (livesupport:continuable 39 | (cepl:step-host)) 40 | ;; update temporal pool 41 | ,(when (find-package :temporal-functions) 42 | `(livesupport:continuable 43 | (,(intern "UPDATE" :ttm)))) 44 | ;; run step function 45 | (livesupport:continuable 46 | (,step-func-name))))) 47 | (unless (= ,frame-var-name 0) 48 | (as-frame 49 | (with-setf (clear-color) (v! 0 1 0 1) 50 | (cls)))) 51 | (setf ,frame-var-name 0) 52 | (format t "~%~%- stopping ~a -~%" ',name))) 53 | (format t "~%~%- ~a is already running -~%" ',name))) 54 | (:stop 55 | (setf ,frame-var-name (max 0 (or frames 0)))))) 56 | (defun ,step-func-name () 57 | ,@body)))) 58 | 59 | (defun set-viewport-dimensions-to-same-as-window 60 | (&key (viewport (current-viewport)) 61 | (window (cepl.context:current-surface 62 | (cepl.context:cepl-context))) 63 | (step-host nil)) 64 | (when window 65 | (when step-host 66 | (cepl:step-host)) 67 | (let ((win-dim (cepl.host:window-size window))) 68 | (setf (viewport-dimensions viewport) win-dim)))) 69 | -------------------------------------------------------------------------------- /normals/calculate-normals.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.normals) 2 | 3 | (defun-g simple-sample-normals ((func (function (:vec2) :float)) 4 | (pos :vec2) 5 | (offset :float) 6 | (scale :float)) 7 | (let* ((s0 (* (funcall func (+ pos (* offset (v! 0f0 -1f0)))) 8 | scale)) 9 | (s1 (* (funcall func (+ pos (* offset (v! -1f0 0f0)))) 10 | scale)) 11 | (s2 (* (funcall func (+ pos (* offset (v! 1f0 0f0)))) 12 | scale)) 13 | (s3 (* (funcall func (+ pos (* offset (v! 0f0 1f0)))) 14 | scale))) 15 | (normalize 16 | (v! (- s1 s2) 17 | 2f0 18 | (- s0 s3))))) 19 | 20 | (defun-g simple-sample-normals ((func (function (:vec2) :float)) 21 | (pos :vec2) 22 | (offset :float)) 23 | (let ((scale 1f0) 24 | (s0 (funcall func (+ pos (v! (- offset) (- offset))))) 25 | (s1 (funcall func (+ pos (v! .0 (- offset))))) 26 | (s2 (funcall func (+ pos (v! offset (- offset))))) 27 | (s3 (funcall func (+ pos (v! (- offset) .0)))) 28 | (s5 (funcall func (+ pos (v! offset .0)))) 29 | (s6 (funcall func (+ pos (v! (- offset) offset)))) 30 | (s7 (funcall func (+ pos (v! .0 offset)))) 31 | (s8 (funcall func (+ pos (v! offset offset))))) 32 | (normalize 33 | (v! (* scale (- (- s2 (- (+ s0 (+ (* 2 (- s5 s3)) s8)) s6)))) 34 | 1f0 35 | (* scale (- (- s6 (- (+ s0 (+ (* 2 (- s7 s1)) s8)) s2)))))))) 36 | 37 | (defun-g simple-sample-normals ((func (function (:vec2) :float)) 38 | (pos :vec2) 39 | (offset :vec2)) 40 | (let ((scale 1f0) 41 | (s0 (funcall func (+ pos (v! (- (x offset)) (- (y offset)))))) 42 | (s1 (funcall func (+ pos (v! .0 (- (y offset)))))) 43 | (s2 (funcall func (+ pos (v! (x offset) (- (y offset)))))) 44 | (s3 (funcall func (+ pos (v! (- (x offset)) .0)))) 45 | (s5 (funcall func (+ pos (v! (x offset) .0)))) 46 | (s6 (funcall func (+ pos (v! (- (x offset)) (y offset))))) 47 | (s7 (funcall func (+ pos (v! .0 (y offset))))) 48 | (s8 (funcall func (+ pos (v! (x offset) (y offset)))))) 49 | (normalize 50 | (v! (* scale (- (- s2 (- (+ s0 (+ (* 2 (- s5 s3)) s8)) s6)))) 51 | 1f0 52 | (* scale (- (- s6 (- (+ s0 (+ (* 2 (- s7 s1)) s8)) s2)))))))) 53 | 54 | 55 | (defun-g simple-sample-normals ((func (function (:vec3) :float)) 56 | (pos :vec3) 57 | (offset :float)) 58 | (normalize 59 | (v! (- (funcall func (+ pos (v! offset 0f0 0f0))) 60 | (funcall func (+ pos (v! (- offset) 0f0 0f0)))) 61 | 62 | (- (funcall func (+ pos (v! 0f0 offset 0f0))) 63 | (funcall func (+ pos (v! 0f0 (- offset) 0f0)))) 64 | 65 | (- (funcall func (+ pos (v! 0f0 0f0 offset))) 66 | (funcall func (+ pos (v! 0f0 0f0 (- offset)))))))) 67 | -------------------------------------------------------------------------------- /noise/value-perlin.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.noise) 2 | 3 | ;;------------------------------------------------------------ 4 | ;; 2D 5 | 6 | (defun-g value-perlin-noise ((p :vec2) (blend-val :float)) 7 | (let* ((pi (floor p)) 8 | (pf-pfmin1 (- (s~ p :xyxy) (v! pi (+ pi (v2! 1.0)))))) 9 | (multiple-value-bind (hash-value hash-x hash-y) 10 | (bs-fast32-hash-3-per-corner pi) 11 | (let* ((grad-x (- hash-x (v4! "0.49999"))) 12 | (grad-y (- hash-y (v4! "0.49999"))) 13 | (grad-results 14 | (* (inversesqrt (+ (* grad-x grad-x) (* grad-y grad-y))) 15 | (+ (* grad-x (s~ pf-pfmin1 :xzxz)) 16 | (* grad-y (s~ pf-pfmin1 :yyww)))))) 17 | (multf grad-results (v4! "1.4142135623730950488016887242097")) 18 | (setf grad-results 19 | (mix (- (* hash-value 2.0) (v4! 1.0)) grad-results blend-val)) 20 | (let* ((blend (quintic (s~ pf-pfmin1 :xy))) 21 | (blend2 (v! blend (- (v2! 1.0) blend)))) 22 | (dot grad-results (* (s~ blend2 :zxzx) (s~ blend2 :wwyy)))))))) 23 | 24 | ;;------------------------------------------------------------ 25 | ;; 3D 26 | 27 | (defun-g value-perlin-noise ((p :vec3) (blend-val :float)) 28 | (let* ((pi (floor p)) 29 | (pf (- p pi)) 30 | (pf-min1 (- pf (v3! 1.0)))) 31 | (multiple-value-bind (hash-value0 32 | hashx0 hashy0 hashz0 33 | hash-value1 34 | hashx1 hashy1 hashz1) 35 | (bs-fast32-hash-4-per-corner pi) 36 | (let* ((grad-x0 (- hashx0 (v4! "0.49999"))) 37 | (grad-y0 (- hashy0 (v4! "0.49999"))) 38 | (grad-z0 (- hashz0 (v4! "0.49999"))) 39 | (grad-x1 (- hashx1 (v4! "0.49999"))) 40 | (grad-y1 (- hashy1 (v4! "0.49999"))) 41 | (grad-z1 (- hashz1 (v4! "0.49999"))) 42 | (grad-results-0 43 | (* 44 | (inversesqrt 45 | (+ (* grad-x0 grad-x0) 46 | (+ (* grad-y0 grad-y0) (* grad-z0 grad-z0)))) 47 | (+ (* (s~ (v2! (x pf) (x pf-min1)) :xyxy) grad-x0) 48 | (+ (* (s~ (v2! (y pf) (y pf-min1)) :xxyy) grad-y0) 49 | (* (s~ pf :zzzz) grad-z0))))) 50 | (grad-results-1 51 | (* 52 | (inversesqrt 53 | (+ (* grad-x1 grad-x1) 54 | (+ (* grad-y1 grad-y1) (* grad-z1 grad-z1)))) 55 | (+ (* (s~ (v2! (x pf) (x pf-min1)) :xyxy) grad-x1) 56 | (+ (* (s~ (v2! (y pf) (y pf-min1)) :xxyy) grad-y1) 57 | (* (s~ pf-min1 :zzzz) grad-z1)))))) 58 | (multf grad-results-0 (v4! "1.1547005383792515290182975610039")) 59 | (multf grad-results-1 (v4! "1.1547005383792515290182975610039")) 60 | (setf grad-results-0 61 | (mix (- (* hash-value0 2.0) (v4! 1.0)) grad-results-0 blend-val)) 62 | (setf grad-results-1 63 | (mix (- (* hash-value1 2.0) (v4! 1.0)) grad-results-1 blend-val)) 64 | (let* ((blend (quintic pf)) 65 | (res0 (mix grad-results-0 grad-results-1 (z blend))) 66 | (blend2 (v! (s~ blend :xy) (- (v2! 1.0) (s~ blend :xy))))) 67 | (dot res0 (* (s~ blend2 :zxzx) (s~ blend2 :wwyy)))))))) 68 | -------------------------------------------------------------------------------- /noise/cubist.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.noise) 2 | 3 | ;;------------------------------------------------------------ 4 | ;; 2D 5 | 6 | (defun-g cubist-noise ((p :vec2) (range-clamp :vec2)) 7 | (let* ((pi (floor p)) 8 | (pf-pfmin1 (- (s~ p :xyxy) (v! pi (+ pi (v2! 1.0)))))) 9 | (multiple-value-bind (hash-x hash-y hash-value) 10 | (bs-fast32-hash-3-per-corner pi) 11 | (let* ((grad-x (- hash-x (v4! "0.49999"))) 12 | (grad-y (- hash-y (v4! "0.49999"))) 13 | (grad-results 14 | (* (inversesqrt (+ (* grad-x grad-x) (* grad-y grad-y))) 15 | (+ (* grad-x (s~ pf-pfmin1 :xzxz)) 16 | (* grad-y (s~ pf-pfmin1 :yyww)))))) 17 | (setf grad-results (* (- hash-value (v4! 0.5)) 18 | (/ (v4! 1.0) grad-results))) 19 | (let* ((blend (quintic (s~ pf-pfmin1 :xy))) 20 | (blend2 (v! blend (- (v2! 1.0) blend))) 21 | (final (dot grad-results (* (s~ blend2 :zxzx) 22 | (s~ blend2 :wwyy))))) 23 | (clamp (* (- final (x range-clamp)) (y range-clamp)) 0.0 1.0)))))) 24 | 25 | ;;------------------------------------------------------------ 26 | ;; 3D 27 | 28 | (defun-g cubist-noise ((p :vec3) (range-clamp :vec2)) 29 | (let* ((pi (floor p)) 30 | (pf (- p pi)) 31 | (pf-min1 (- pf (v3! 1.0)))) 32 | (multiple-value-bind (hashx0 hashy0 hashz0 33 | hash-value0 34 | hashx1 hashy1 hashz1 35 | hash-value1) 36 | (bs-fast32-hash-4-per-corner pi) 37 | (let* ((grad-x0 (- hashx0 (v4! "0.49999"))) 38 | (grad-y0 (- hashy0 (v4! "0.49999"))) 39 | (grad-z0 (- hashz0 (v4! "0.49999"))) 40 | (grad-x1 (- hashx1 (v4! "0.49999"))) 41 | (grad-y1 (- hashy1 (v4! "0.49999"))) 42 | (grad-z1 (- hashz1 (v4! "0.49999"))) 43 | (grad-results-0 44 | (* 45 | (inversesqrt 46 | (+ (* grad-x0 grad-x0) 47 | (+ (* grad-y0 grad-y0) (* grad-z0 grad-z0)))) 48 | (+ (* (s~ (v2! (x pf) (x pf-min1)) :xyxy) grad-x0) 49 | (+ (* (s~ (v2! (y pf) (y pf-min1)) :xxyy) grad-y0) 50 | (* (s~ pf :zzzz) grad-z0))))) 51 | (grad-results-1 52 | (* 53 | (inversesqrt 54 | (+ (* grad-x1 grad-x1) 55 | (+ (* grad-y1 grad-y1) (* grad-z1 grad-z1)))) 56 | (+ (* (s~ (v2! (x pf) (x pf-min1)) :xyxy) grad-x1) 57 | (+ (* (s~ (v2! (y pf) (y pf-min1)) :xxyy) grad-y1) 58 | (* (s~ pf-min1 :zzzz) grad-z1)))))) 59 | (setf grad-results-0 (* (- hash-value0 (v4! 0.5)) 60 | (/ (v4! 1.0) grad-results-0))) 61 | (setf grad-results-1 (* (- hash-value1 (v4! 0.5)) 62 | (/ (v4! 1.0) grad-results-1))) 63 | (let* ((blend (quintic pf)) 64 | (res0 (mix grad-results-0 grad-results-1 (z blend))) 65 | (blend2 (v! (s~ blend :xy) (- (v2! 1.0) (s~ blend :xy)))) 66 | (final (dot res0 (* (s~ blend2 :zxzx) (s~ blend2 :wwyy))))) 67 | (clamp (* (- final (x range-clamp)) (y range-clamp)) 0.0 1.0)))))) 68 | -------------------------------------------------------------------------------- /noise/value-hermite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.noise) 2 | 3 | ;;------------------------------------------------------------ 4 | ;; 2D 5 | 6 | (defun-g value-hermite-noise ((p :vec2) 7 | (value-scale :float) 8 | (gradient-scale :float) 9 | (normalization-val :float)) 10 | (let* ((pi (floor p)) 11 | (pf (- p pi))) 12 | (multiple-value-bind (hash-value hash-gradx hash-grady) 13 | (bs-fast32-hash-3-per-corner pi) 14 | (setf hash-gradx (* (- hash-gradx (v4! "0.49999")) gradient-scale)) 15 | (setf hash-grady (* (- hash-grady (v4! "0.49999")) gradient-scale)) 16 | (setf hash-value (* (- hash-value (v4! 0.5)) value-scale)) 17 | (let* ((qh-results 18 | (quintic-hermite (y pf) 19 | (v! (s~ hash-value :xy) (s~ hash-gradx :xy)) 20 | (v! (s~ hash-value :zw) (s~ hash-gradx :zw)) 21 | (v! (s~ hash-grady :xy) 0.0 0.0) 22 | (v! (s~ hash-grady :zw) 0.0 0.0)))) 23 | (* (quintic-hermite (x pf) (x qh-results) (y qh-results) (z qh-results) 24 | (w qh-results)) 25 | normalization-val))))) 26 | 27 | ;;------------------------------------------------------------ 28 | ;; 3D 29 | 30 | (defun-g value-hermite-noise ((p :vec3) 31 | (value-scale :float) 32 | (gradient-scale :float) 33 | (normalization-val :float)) 34 | (let* ((pi (floor p)) 35 | (pf (- p pi))) 36 | (multiple-value-bind (hash-value0 37 | hash-gradx0 hash-grady0 hash-gradz0 38 | hash-value1 39 | hash-gradx1 hash-grady1 hash-gradz1) 40 | (bs-fast32-hash-4-per-corner pi) 41 | (setf hash-gradx0 (* (- hash-gradx0 (v4! "0.49999")) gradient-scale)) 42 | (setf hash-grady0 (* (- hash-grady0 (v4! "0.49999")) gradient-scale)) 43 | (setf hash-gradz0 (* (- hash-gradz0 (v4! "0.49999")) gradient-scale)) 44 | (setf hash-gradx1 (* (- hash-gradx1 (v4! "0.49999")) gradient-scale)) 45 | (setf hash-grady1 (* (- hash-grady1 (v4! "0.49999")) gradient-scale)) 46 | (setf hash-gradz1 (* (- hash-gradz1 (v4! "0.49999")) gradient-scale)) 47 | (setf hash-value0 (* (- hash-value0 (v4! 0.5)) value-scale)) 48 | (setf hash-value1 (* (- hash-value1 (v4! 0.5)) value-scale)) 49 | (multiple-value-bind (ival-results igrad-results-x igrad-results-y) 50 | (quintic-hermite (z pf) 51 | hash-value0 hash-value1 hash-gradx0 hash-gradx1 52 | hash-grady0 hash-grady1 hash-gradz0 hash-gradz1) 53 | (let* ((qh-results 54 | (quintic-hermite (y pf) 55 | (v! (s~ ival-results :xy) (s~ igrad-results-x :xy)) 56 | (v! (s~ ival-results :zw) (s~ igrad-results-x :zw)) 57 | (v! (s~ igrad-results-y :xy) 0.0 0.0) 58 | (v! (s~ igrad-results-y :zw) 0.0 0.0)))) 59 | (* 60 | (quintic-hermite (x pf) (x qh-results) (y qh-results) (z qh-results) 61 | (w qh-results)) 62 | normalization-val)))))) 63 | -------------------------------------------------------------------------------- /easing/easing.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.easing) 2 | 3 | ;; Note: it is know that these are really inefficient implementations for the 4 | ;; GPU. This was a 5min coversions from the originals (which was super 5 | ;; cool!) and will be fixed up in due course 6 | 7 | (defmacro defeasing-f (name args &body body) 8 | (let ((ease-in (alexandria:symbolicate 'in- name)) 9 | (ease-out (alexandria:symbolicate 'out- name)) 10 | (ease-in-out (alexandria:symbolicate 'in-out- name))) 11 | `(progn 12 | ;; in 13 | (cepl.pipelines::defun-g-equiv ,ease-in ,args 14 | ,@body) 15 | ;; out 16 | (cepl.pipelines::defun-g-equiv ,ease-out ,args 17 | (let ((x (- 1s0 x))) 18 | (- 1s0 (progn ,@body)))) 19 | ;; in-out 20 | (cepl.pipelines::defun-g-equiv ,ease-in-out ,args 21 | (if (<= x 0.5s0) 22 | (let ((x (* 2s0 x))) 23 | (/ (progn ,@body) 2s0)) 24 | (let ((x (- 1s0 (* 2s0 (- x 0.5s0))))) 25 | (+ 0.5s0 (/ (- 1s0 (progn ,@body)) 26 | 2s0)))))))) 27 | 28 | (defun-g linear ((x :float)) 29 | ;; but why? 30 | x) 31 | 32 | (defeasing-f sine ((x :float)) 33 | (- 1s0 (cos (* x (/ +pi+ 2s0))))) 34 | 35 | (defeasing-f quad ((x :float)) 36 | (* x x)) 37 | 38 | (defeasing-f cubic ((x :float)) 39 | (* x x x)) 40 | 41 | (defeasing-f quart ((x :float)) 42 | (expt x 4s0)) 43 | 44 | (defeasing-f quint ((x :float)) 45 | (expt x 5s0)) 46 | 47 | (defeasing-f exp ((x :float)) 48 | (expt 2s0 (* 10s0 (- x 1s0)))) 49 | 50 | (defeasing-f circ ((x :float)) 51 | (- (- (sqrt (- 1s0 (* x x))) 52 | 1s0))) 53 | 54 | (defeasing-f elastic ((x :float) (p :float) (s :float)) 55 | (- (* (expt 2 (* 10 (- x 1s0))) 56 | (sin (/ (* (- (- x 1s0) s) (* 2 +pi+)) p))))) 57 | 58 | (defeasing-f elastic ((x :float) (p :float)) 59 | (let ((s (* #.(asin 1s0) (* p #.(/ 1s0 (* 2s0 +pi+)))))) 60 | (- (* (expt 2 (* 10 (- x 1s0))) 61 | (sin (/ (* (- (- x 1s0) s) (* 2 +pi+)) p)))))) 62 | 63 | (defeasing-f elastic ((x :float)) 64 | (let ((s (* #.(asin 1s0) (* 0.3f0 #.(/ 1s0 (* 2s0 +pi+)))))) 65 | (- (* (expt 2 (* 10 (- x 1s0))) 66 | (sin (/ (* (- (- x 1s0) s) (* 2 +pi+)) 0.3f0)))))) 67 | 68 | (defeasing-f back ((x :float) (s :float)) 69 | (* x x (- (* (+ 1s0 s) x) s))) 70 | 71 | (defeasing-f back ((x :float)) 72 | (* x x (- (* (+ 1s0 1.70158s0) x) 1.70158s0))) 73 | 74 | (defeasing-f bounce ((x :float) (c1 :float)) 75 | (let ((x (- 1s0 x))) 76 | (- 1s0 (cond ((< x (/ 1s0 2.75)) (* c1 x x)) 77 | ((< x (/ 2s0 2.75s0)) (let ((x (- x (/ 1.5s0 2.75s0)))) 78 | (+ 0.75s0 (* c1 x x)))) 79 | ((< x (/ 2.5s0 2.75s0)) (let ((x (- x (/ 2.25 2.75)))) 80 | (+ 0.9375s0 (* c1 x x)))) 81 | (t (let ((x (- x (/ 2.625s0 2.75s0)))) 82 | (+ 0.984375s0 (* c1 x x)))))))) 83 | 84 | (defeasing-f bounce ((x :float)) 85 | (let ((x (- 1s0 x))) 86 | (- 1s0 (cond ((< x (/ 1s0 2.75)) (* 7.5625 x x)) 87 | ((< x (/ 2s0 2.75s0)) (let ((x (- x (/ 1.5s0 2.75s0)))) 88 | (+ 0.75s0 (* 7.5625 x x)))) 89 | ((< x (/ 2.5s0 2.75s0)) (let ((x (- x (/ 2.25 2.75)))) 90 | (+ 0.9375s0 (* 7.5625 x x)))) 91 | (t (let ((x (- x (/ 2.625s0 2.75s0)))) 92 | (+ 0.984375s0 (* 7.5625 x x)))))))) 93 | -------------------------------------------------------------------------------- /textures/hdr-cross-cube-map-loader.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.textures) 2 | 3 | (defun load-hdr-cross-texture (filepath) 4 | (with-c-arrays-freed (c-arrays (load-hdr-cross-image filepath)) 5 | (make-texture c-arrays :element-type :rgb16f :cubes t))) 6 | 7 | (defun load-hdr-cross-image (filepath) 8 | (destructuring-bind (ptr width height components-per-pixel) 9 | (stbi:loadf filepath) 10 | (unwind-protect 11 | (%load-hdr-cross-image ptr width height components-per-pixel) 12 | (cffi:foreign-free ptr)))) 13 | 14 | (defun %load-hdr-cross-image (ptr width height components-per-pixel) 15 | (let* ((face-width (/ width 3)) 16 | (face-height (/ height 4)) 17 | (dim (list face-width face-height)) 18 | (line-float-width (* width components-per-pixel)) 19 | (offsets `((,face-width 0) 20 | (0 ,face-height) 21 | (,face-width ,face-height) 22 | (,(* face-width 2) ,face-height) 23 | (,face-width ,(* face-height 2)) 24 | (,face-width ,(* face-height 3))))) 25 | (assert (and (= (mod width 3) 0) 26 | (= (mod height 4) 0) 27 | (= face-width face-height) 28 | (= components-per-pixel 3))) 29 | (let ((arrays 30 | (loop :for f :below 6 :collect 31 | (let ((arr 32 | (make-c-array nil :dimensions dim :element-type :vec3)) 33 | (offset (elt offsets f))) 34 | (destructuring-bind (x-offset y-offset) offset 35 | (loop :for y :below face-height :do 36 | (loop :for x :below face-width :do 37 | (let* ((line-offset (* line-float-width (+ y y-offset))) 38 | (face-offset (+ line-offset 39 | (* x-offset components-per-pixel))) 40 | (index (+ face-offset (* x components-per-pixel)))) 41 | (if (= f 5) 42 | (setf (aref-c arr 43 | (- face-width (1+ x)) 44 | (- face-height (1+ y))) 45 | (v! (cffi:mem-aref ptr :float index) 46 | (cffi:mem-aref ptr :float (+ index 1)) 47 | (cffi:mem-aref ptr :float (+ index 2)))) 48 | (setf (aref-c arr x y) 49 | (v! (cffi:mem-aref ptr :float index) 50 | (cffi:mem-aref ptr :float (+ index 1)) 51 | (cffi:mem-aref ptr :float (+ index 2))))))))) 52 | arr)))) 53 | ;; 0 GL_TEXTURE_CUBE_MAP_POSITIVE_X 54 | ;; 1 GL_TEXTURE_CUBE_MAP_NEGATIVE_X 55 | ;; 2 GL_TEXTURE_CUBE_MAP_POSITIVE_Y 56 | ;; 3 GL_TEXTURE_CUBE_MAP_NEGATIVE_Y 57 | ;; 4 GL_TEXTURE_CUBE_MAP_POSITIVE_Z 58 | ;; 5 GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 59 | (mapcar (lambda (x) (elt arrays x)) 60 | '(3 1 0 4 2 5))))) 61 | 62 | 63 | (defun load-hdr-2d (filepath) 64 | (destructuring-bind (ptr width height components-per-pixel) 65 | (stbi:loadf filepath) 66 | (assert (and (= components-per-pixel 3))) 67 | (with-c-array-freed (c-array (make-c-array-from-pointer 68 | (list width height) :vec3 ptr)) 69 | (make-texture c-array :element-type :rgb16f)))) 70 | -------------------------------------------------------------------------------- /nineveh.asd: -------------------------------------------------------------------------------- 1 | ;;;; nineveh.asd 2 | 3 | (asdf:defsystem #:nineveh 4 | :description "A library of common gpu functions" 5 | :author "Chris Bagley (Baggers) " 6 | :license "BSD 2 Clause" 7 | :serial t 8 | :depends-on (#:cepl #:cl-soil #:livesupport #:easing 9 | #:documentation-utils #:dendrite.primitives 10 | #:rtg-math.vari #:with-setf) 11 | :components ((:file "package") 12 | ;; 13 | (:file "internals/quad") 14 | ;; 15 | (:file "math-primitives/log") 16 | (:file "math-primitives/clamping") 17 | (:file "math-primitives/mod") 18 | (:file "math-primitives/atan2") 19 | (:file "math-primitives/remap") 20 | (:file "math-primitives/radical-inverse") 21 | (:file "math-primitives/vmax") 22 | (:file "math-primitives/docs") 23 | ;; 24 | (:file "conditionals/conditional-optimizations") 25 | ;; 26 | (:file "color/color-space-conversions") 27 | (:file "color/sets") 28 | (:file "color/luminance") 29 | ;; 30 | (:file "hashing/blum-blum-shub-hash") 31 | (:file "hashing/permutation-polynomial-hash") 32 | (:file "hashing/bsharpe-fast-32-hash") 33 | (:file "hashing/bsharpe-quick32-hash") 34 | (:file "hashing/docs") 35 | ;; 36 | (:file "shaping-functions/to-sort") 37 | (:file "shaping-functions/interpolation") 38 | (:file "shaping-functions/falloff") 39 | (:file "shaping-functions/polynominal") 40 | ;; 41 | (:file "noise/simplex-helpers") 42 | (:file "noise/value-noise") 43 | (:file "noise/perlin") 44 | (:file "noise/value-perlin") 45 | (:file "noise/cubist") 46 | (:file "noise/cellular") 47 | (:file "noise/misc") 48 | (:file "noise/hermite") 49 | (:file "noise/value-hermite") 50 | ;; 51 | (:file "easing/easing") 52 | (:file "random/random") 53 | (:file "random/hammersley") 54 | (:file "random/docs") 55 | ;; 56 | (:file "mesh/data/primitives") 57 | ;; 58 | (:file "normals/calculate-normals") 59 | ;; 60 | (:file "graphing/axis") 61 | (:file "graphing/graph") 62 | (:file "graphing/plot") 63 | ;; 64 | (:file "textures/sampling") 65 | (:file "textures/draw-texture") 66 | (:file "textures/dirty-blit") 67 | (:file "textures/cube-tex-fbos") 68 | (:file "textures/hdr-cross-cube-map-loader") 69 | ;; 70 | (:file "streams/buffer-streamer") 71 | (:file "streams/quad-streams") 72 | ;; 73 | (:file "tonemapping/operators") 74 | ;; 75 | (:file "sdf/2d/sdf") 76 | ;; 77 | (:file "vignette/vignette") 78 | ;; 79 | (:file "distortion/distortion") 80 | ;; 81 | (:file "antialiasing/fxaa2") 82 | (:file "antialiasing/fxaa3") 83 | ;; 84 | (:file "graphing/particle/particle-graph") 85 | ;; 86 | (:file "misc"))) 87 | -------------------------------------------------------------------------------- /shaping-functions/polynominal.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.shaping-functions) 2 | 3 | ;; 4 | ;; 5 | ;; Some polynomial functions for shaping, tweening, and easing signals in the 6 | ;; range [0..1] 7 | ;; 8 | ;; 9 | 10 | (defun-g cos-raised-inverted-blinn-wybill ((x :float)) 11 | "Approximation of 'raised inverted cosine'. Diverges from real function 12 | by less that 0.1% within the range [0..1]. 13 | 14 | It also shares some of the Raised Inverted Cosine's key properties, having 15 | flat derivatives at 0 and 1, and the value 0.5 at x=0.5. 16 | 17 | Credit: 18 | Golan Levin and Collaborators: http://www.flong.com/texts/code/shapers_poly/ 19 | " 20 | (let* ((x² (* x x)) 21 | (x⁴ (* x² x²)) 22 | (x⁶ (* x⁴ x²)) 23 | ;; 24 | (fa (/ 4f0 9f0)) 25 | (fb (/ 17f0 9f0)) 26 | (fc (/ 22f0 9f0)) 27 | (y (+ (- (* fa x⁶) (* fb x⁴)) 28 | (* fc x²)))) 29 | y)) 30 | 31 | (defun-g seat-double-cubic ((inflection-point :vec2) (x :float)) 32 | "This seat-shaped function is formed by joining two 3rd-order polynomial 33 | (cubic) curves. The curves meet with a horizontal inflection point at the 34 | control coordinate specified by 'inflection-point' in the unit square. 35 | 36 | Credit: 37 | Golan Levin and Collaborators: http://www.flong.com/texts/code/shapers_poly/ 38 | " 39 | (let* ((epsilon (glsl-expr "0.00001" :float)) 40 | (min-a epsilon) 41 | (max-a (- 1f0 epsilon)) 42 | (min-b 0f0) 43 | (max-b 1f0) 44 | (a (clamp (x inflection-point) min-a max-a)) 45 | (b (clamp (y inflection-point) min-b max-b))) 46 | (if (<= x a) 47 | (- b (* b (pow (- 1 (/ x a)) 3f0))) 48 | (+ b (* (- 1 b) (pow (/ (- x a) (- 1 a)) 3f0)))))) 49 | 50 | (defun-g seat-double-cubic-with-linear-bend ((inflection-point :float) 51 | (amount-of-blend :float) 52 | (x :float)) 53 | "This is a modified version of #'seat-double-cubic. 54 | 55 | It uses 'inflection-point' to control the location of its inflection point 56 | along the diagonal of the unit square. 57 | 58 | 'amount-of-blend' is used to control the how much we blend this curve with 59 | the Identity Function (y=x). This has the effect of tilting the slope of 60 | the curve's plateau in the vicinity of its inflection point. 61 | 62 | The adjustable flattening around the inflection point makes this a useful 63 | shaping function for lensing or magnifying evenly-spaced data. 64 | 65 | Credit: 66 | Golan Levin and Collaborators: http://www.flong.com/texts/code/shapers_poly/ 67 | " 68 | (let* ((epsilon (glsl-expr "0.00001" :float)) 69 | (min-a epsilon) 70 | (max-a (- 1f0 epsilon)) 71 | (min-b 0f0) 72 | (max-b 1f0) 73 | (a (clamp inflection-point min-a max-a)) 74 | (b (clamp amount-of-blend min-b max-b)) 75 | (b (- 1f0 b))) 76 | (if (<= x a) 77 | (+ (* b x) (* (- 1 b) a (- 1 (pow (- 1 (/ x a)) 3f0)))) 78 | (+ (* b x) 79 | (* (- 1 b) 80 | (+ a (* (- 1 a) (pow (/ (- x a) (- 1 a)) 3f0)))))))) 81 | 82 | (defun-g seat-double-odd-exponent ((inflection-point :vec2) 83 | (exponent :int) 84 | (x :float)) 85 | "This is the seat-double-cubic generalized to work with any odd exponent. 86 | The viable value for 'exponent' are the odd integers from 1 to 19. 87 | 88 | Credit: 89 | Golan Levin and Collaborators: http://www.flong.com/texts/code/shapers_poly/ 90 | " 91 | (let* ((epsilon (glsl-expr "0.00001" :float)) 92 | (min-a epsilon) 93 | (max-a (- 1f0 epsilon)) 94 | (min-b 0f0) 95 | (max-b 1f0) 96 | (a (clamp (x inflection-point) min-a max-a)) 97 | (b (clamp (y inflection-point) min-b max-b)) 98 | (p (+ (* 2 exponent) 1))) 99 | (if (<= x a) 100 | (- b (* b (pow (- 1 (/ x a)) p))) 101 | (+ b (* (- 1 b) (pow (/ (- x a) (- 1 a)) p)))))) 102 | 103 | ;; {TODO} Investifate switching away from conditions 104 | -------------------------------------------------------------------------------- /noise/misc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.noise) 2 | 3 | ;;---------------------------------------------------------------------- 4 | ;; 2D 5 | 6 | (defun-g polka-dot-noise ((p :vec2) (radius-low :float) (radius-high :float)) 7 | (let* ((pi (floor p)) 8 | (pf (- p pi)) 9 | (hash (bs-fast32-hash-cell pi)) 10 | (radius 11 | (max 0.0 (+ radius-low (* (z hash) (- radius-high radius-low))))) 12 | (value (/ radius (max radius-high radius-low)))) 13 | (setf radius (/ 2.0 radius)) 14 | (multf pf (v2! radius)) 15 | (decf pf (v2! (- radius 1.0))) 16 | (incf pf (* (s~ hash :xy) (- radius 2.0))) 17 | (* (falloff-xsq-c2 (min (dot pf pf) 1.0)) value))) 18 | 19 | (defun-g polka-dot-noise-simplex ((p :vec2) 20 | (radius :float) 21 | (max-dimness :float)) 22 | (let* ((skew-factor 0.36602542) 23 | (unskew-factor 0.21132489) 24 | (simplex-tri-height 0.7071068) 25 | (inv-simplex-tri-half-edgelen 2.4494898) 26 | (simplex-points 27 | (v3! (- 1.0 unskew-factor) (- unskew-factor) 28 | (- 1.0 (* 2.0 unskew-factor))))) 29 | (multf p (v2! simplex-tri-height)) 30 | (let* ((pi (floor (+ p (v2! (dot p (v2! skew-factor)))))) 31 | (v0 (- pi (- (v2! (dot pi (v2! unskew-factor))) p))) 32 | (v0123-x (+ (v! 0.0 (s~ simplex-points :xyz)) (v4! (x v0)))) 33 | (v0123-y (+ (v! 0.0 (s~ simplex-points :yxz)) (v4! (y v0)))) 34 | (hash (bs-fast32-hash pi))) 35 | (setf radius (/ inv-simplex-tri-half-edgelen radius)) 36 | (multf v0123-x (v4! radius)) 37 | (multf v0123-y (v4! radius)) 38 | (let* ((point-distance 39 | (max (v4! 0.0) 40 | (- (v4! 1.0) (+ (* v0123-x v0123-x) (* v0123-y v0123-y)))))) 41 | (setf point-distance 42 | (* point-distance (* point-distance point-distance))) 43 | (dot (- (v4! 1.0) (* hash max-dimness)) point-distance))))) 44 | 45 | (defun-g stars-noise ((p :vec2) 46 | (probability-threshold :float) 47 | (max-dimness :float) 48 | (two-over-radius :float)) 49 | (let* ((pi (floor p)) 50 | (pf (- p pi)) 51 | (hash (bs-fast32-hash-cell pi)) 52 | (value (- 1.0 (* max-dimness (z hash))))) 53 | (multf pf (v2! two-over-radius)) 54 | (decf pf (v2! (- two-over-radius 1.0))) 55 | (incf pf (* (s~ hash :xy) (- two-over-radius 2.0))) 56 | (if (< (w hash) probability-threshold) 57 | (* (falloff-xsq-c1 (min (dot pf pf) 1.0)) value) 58 | 0.0))) 59 | 60 | ;;---------------------------------------------------------------------- 61 | 62 | (defun-g polka-dot-noise ((p :vec3) (radius-low :float) (radius-high :float)) 63 | (let* ((pi (floor p)) 64 | (pf (- p pi)) 65 | (hash (bs-fast32-hash-cell pi)) 66 | (radius 67 | (max 0.0 (+ radius-low (* (w hash) (- radius-high radius-low))))) 68 | (value (/ radius (max radius-high radius-low)))) 69 | (setf radius (/ 2.0 radius)) 70 | (multf pf (v3! radius)) 71 | (decf pf (v3! (- radius 1.0))) 72 | (incf pf (* (s~ hash :xyz) (- radius 2.0))) 73 | (* (falloff-xsq-c2 (min (dot pf pf) 1.0)) value))) 74 | 75 | 76 | (defun-g polka-dot-noise-simplex ((p :vec3) (radius :float) (max-dimness :float)) 77 | (multiple-value-bind (pi pi-1 pi-2 v1234-x v1234-y v1234-z) 78 | (simplex-3d-get-corner-vectors p) 79 | (let* ((hash (bs-fast32-hash pi pi-1 pi-2)) 80 | (inv-simplex-tri-half-edgelen 2.309401)) 81 | (setf radius (/ inv-simplex-tri-half-edgelen radius)) 82 | (multf v1234-x (v4! radius)) 83 | (multf v1234-y (v4! radius)) 84 | (multf v1234-z (v4! radius)) 85 | (let* ((point-distance 86 | (max (v4! 0.0) 87 | (- (v4! 1.0) 88 | (+ (* v1234-x v1234-x) 89 | (+ (* v1234-y v1234-y) (* v1234-z v1234-z))))))) 90 | (setf point-distance 91 | (* point-distance (* point-distance point-distance))) 92 | (dot (- (v4! 1.0) (* hash max-dimness)) point-distance))))) 93 | 94 | ;;---------------------------------------------------------------------- 95 | -------------------------------------------------------------------------------- /graphing/graph.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.graphing) 2 | 3 | ;; Based on Mikael Hvidtfeldt Christensen's excellent article here: 4 | ;; http://blog.hvidtfeldts.net/index.php/2011/07/plotting-high-frequency-functions-using-a-gpu/ 5 | ;; 6 | ;; We don't use dithering on this version 7 | 8 | (defun-g graph ((func (function (:float) :float)) 9 | (uv :vec2) 10 | (xy-range :vec4) ;; x-min x-max y-min y-max 11 | (line-style :vec4) 12 | (axis-style :vec4) 13 | (samples :int)) 14 | (let* ((axis (axis uv xy-range axis-style)) 15 | ;; 16 | (line-thickness (w line-style)) 17 | (line-color (v! (s~ line-style :xyz) 1)) 18 | ;; 19 | (axis-thickness (w axis-style)) 20 | (axis-color (v! (s~ axis-style :xyz) 1)) 21 | ;; 22 | (diff (v! (- (y xy-range) (x xy-range)) 23 | (- (w xy-range) (z xy-range)))) 24 | ;; 25 | (uv (+ (* uv diff) (s~ xy-range :xz))) 26 | ;; 27 | (samples (float samples)) 28 | (max-dist (* (v2! line-thickness) diff)) 29 | (step (/ max-dist (v2! samples))) 30 | (count 0f0) 31 | (initial-offset (* step samples -0.5)) 32 | (my-samples 0f0)) 33 | (incf initial-offset uv) 34 | (for (i 0f0) (< i samples) (++ i) 35 | (let ((fx (funcall func (+ (x uv) (* i (x step)))))) 36 | (for (j 0f0) (< j samples) (++ j) 37 | (when (> (+ (* i i) (* j j)) (* samples samples)) 38 | (continue)) 39 | (incf my-samples 1f0) 40 | (let ((diff (- fx (+ (y uv) (* j (y step)))))) 41 | (incf count (- (* (step 0f0 diff) 2f0) 1)))))) 42 | (values 43 | (+ (* (if (/= (abs count) my-samples) 44 | (- 1f0 (/ (abs (float count)) (float my-samples))) 45 | 0f0) 46 | line-color) 47 | axis) 48 | (funcall func (x uv))))) 49 | 50 | ;; {TODO} these can go away once varjo has &optional support 51 | 52 | ;;------------------------------------------------------------ 53 | 54 | (defun-g graph ((func (function (:float) :float)) 55 | (uv :vec2) 56 | (xy-range :vec4) ;; x-min x-max y-min y-max 57 | (line-style :vec4) 58 | (axis-style :vec4)) 59 | (graph func uv xy-range line-style axis-style 10)) 60 | 61 | ;;------------------------------------------------------------ 62 | 63 | (defun-g graph ((func (function (:float) :float)) 64 | (uv :vec2) 65 | (xy-range :vec4) ;; x-min x-max y-min y-max 66 | (line-style :float) 67 | (axis-style :float)) 68 | (graph func uv xy-range (v! 1 1 1 line-style) (v! 0.1 0.1 0.1 axis-style) 69 | 10)) 70 | 71 | ;;------------------------------------------------------------ 72 | 73 | (defun-g graph ((func (function (:float) :float)) 74 | (uv :vec2) 75 | (xy-range :vec4) ;; x-min x-max y-min y-max 76 | (line-style :vec4)) 77 | (graph func uv xy-range line-style (v! 0.1 0.1 0.1 0.004) 10)) 78 | 79 | ;;------------------------------------------------------------ 80 | 81 | (defun-g graph ((func (function (:float) :float)) 82 | (uv :vec2) 83 | (xy-range :vec4) ;; x-min x-max y-min y-max 84 | (line-style :float)) 85 | (graph func uv xy-range (v! 1 1 1 line-style) (v! 0.1 0.1 0.1 0.004) 10)) 86 | 87 | ;;------------------------------------------------------------ 88 | 89 | (defun-g graph ((func (function (:float) :float)) 90 | (uv :vec2) 91 | (xy-range :vec4)) ;; x-min x-max y-min y-max 92 | (graph func uv xy-range (v! 1 1 1 0.004) (v! 0.1 0.1 0.1 0.004) 10)) 93 | 94 | ;;------------------------------------------------------------ 95 | 96 | (defun-g graph ((func (function (:float) :float)) 97 | (uv :vec2)) 98 | (graph func 99 | uv 100 | (v! 0 1 0 1) ;; range 101 | (v! 1 1 1 0.004) ;; line-style 102 | (v! 0.1 0.1 0.1 0.004) ;; axis-style 103 | 10)) ;; samples 104 | 105 | ;;------------------------------------------------------------ 106 | -------------------------------------------------------------------------------- /antialiasing/fxaa2.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:nineveh.anti-aliasing) 2 | 3 | (defun-g fxaa2-calc-uvs ((uv :vec2) 4 | (one-over-resolution :vec2) 5 | (fxaa-subpix-shift :float)) 6 | "Can be run in the vertex stage to save cycles" 7 | (vec4 uv 8 | (- uv (* one-over-resolution (+ 0.5 fxaa-subpix-shift))))) 9 | 10 | (defun-g fxaa2-calc-uvs ((uv :vec2) 11 | (one-over-resolution :vec2)) 12 | "Can be run in the vertex stage to save cycles" 13 | (fxaa2-calc-uvs uv one-over-resolution (/ 1.0 4.0))) 14 | 15 | (defun-g fxaa2 ((uvs :vec4) (tex :sampler-2d) (one-over-resolution :vec2)) 16 | (let* (;; These four used to be defines 17 | (fxaa-span-max 8.0) 18 | (fxaa-reduce-mul (/ 1.0 fxaa-span-max)) 19 | (fxaa-reduce-min (/ 1.0 128.0)) 20 | ;; 21 | (rgb-nw 22 | (rtg-math.vectors:s~ 23 | (texture-lod tex (rtg-math.vectors:s~ uvs :zw) 0.0) :xyz)) 24 | (rgb-ne 25 | (rtg-math.vectors:s~ 26 | (texture-lod tex 27 | (+ (rtg-math.vectors:s~ uvs :zw) 28 | (* (rtg-math.base-vectors:v2! 1 0) 29 | (rtg-math.vectors:s~ one-over-resolution :xy))) 30 | 0.0) 31 | :xyz)) 32 | (rgb-sw 33 | (rtg-math.vectors:s~ 34 | (texture-lod tex 35 | (+ (rtg-math.vectors:s~ uvs :zw) 36 | (* (rtg-math.base-vectors:v2! 0 1) 37 | (rtg-math.vectors:s~ one-over-resolution :xy))) 38 | 0.0) 39 | :xyz)) 40 | (rgb-se 41 | (rtg-math.vectors:s~ 42 | (texture-lod tex 43 | (+ (rtg-math.vectors:s~ uvs :zw) 44 | (* (rtg-math.base-vectors:v2! 1 1) 45 | (rtg-math.vectors:s~ one-over-resolution :xy))) 46 | 0.0) 47 | :xyz)) 48 | (rgb-m 49 | (rtg-math.vectors:s~ 50 | (texture-lod tex (rtg-math.vectors:s~ uvs :xy) 0.0) :xyz)) 51 | (luma (rtg-math.base-vectors:v3! 0.29900002 0.587 0.11400001)) 52 | (luma-nw (dot rgb-nw luma)) 53 | (luma-ne (dot rgb-ne luma)) 54 | (luma-sw (dot rgb-sw luma)) 55 | (luma-se (dot rgb-se luma)) 56 | (luma-m (dot rgb-m luma)) 57 | (luma-min 58 | (min luma-m (min (min luma-nw luma-ne) (min luma-sw luma-se)))) 59 | (luma-max 60 | (max luma-m (max (max luma-nw luma-ne) (max luma-sw luma-se)))) 61 | (dir (vec2 (- (- (+ luma-nw luma-ne) (+ luma-sw luma-se))) 62 | (- (+ luma-nw luma-sw) (+ luma-ne luma-se))))) 63 | (let* ((dir-reduce 64 | (max 65 | (* (+ luma-nw (+ luma-ne (+ luma-sw luma-se))) 66 | (* 0.25 fxaa-reduce-mul)) 67 | fxaa-reduce-min)) 68 | (rcp-dir-min 69 | (/ 1.0 (+ (min (abs (x dir)) (abs (y dir))) dir-reduce)))) 70 | (setf dir 71 | (* 72 | (min (rtg-math.base-vectors:v2! fxaa-span-max fxaa-span-max) 73 | (max 74 | (rtg-math.base-vectors:v2! (- fxaa-span-max) 75 | (- fxaa-span-max)) 76 | (* dir rcp-dir-min))) 77 | (rtg-math.vectors:s~ one-over-resolution :xy))) 78 | (let* ((rgb-a 79 | (* (/ 1.0 2.0) 80 | (+ 81 | (rtg-math.vectors:s~ 82 | (texture-lod tex 83 | (+ (rtg-math.vectors:s~ uvs :xy) (* dir (- (/ 1.0 3.0) 0.5))) 84 | 0.0) 85 | :xyz) 86 | (rtg-math.vectors:s~ 87 | (texture-lod tex 88 | (+ (rtg-math.vectors:s~ uvs :xy) (* dir (- (/ 2.0 3.0) 0.5))) 89 | 0.0) 90 | :xyz)))) 91 | (rgb-b 92 | (+ (* rgb-a (/ 1.0 2.0)) 93 | (* (/ 1.0 4.0) 94 | (+ 95 | (rtg-math.vectors:s~ 96 | (texture-lod tex 97 | (+ (rtg-math.vectors:s~ uvs :xy) 98 | (* dir (- (/ 0.0 3.0) 0.5))) 99 | 0.0) 100 | :xyz) 101 | (rtg-math.vectors:s~ 102 | (texture-lod tex 103 | (+ (rtg-math.vectors:s~ uvs :xy) 104 | (* dir (- (/ 3.0 3.0) 0.5))) 105 | 0.0) 106 | :xyz))))) 107 | (luma-b (dot rgb-b luma))) 108 | (if (or (< luma-b luma-min) (> luma-b luma-max)) 109 | rgb-a 110 | rgb-b))))) 111 | -------------------------------------------------------------------------------- /graphing/particle/pipeline-pgraphs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.graphing) 2 | 3 | ;; 4 | ;; This is a simple 3d graph that just uses instanced particles 5 | ;; as the points. Not the best for rapidly changing values but 6 | ;; could be handy for getting a general idea of what a function 7 | ;; is about. 8 | ;; 9 | 10 | ;; NOTE: Not working, this is where we want to get to, however 11 | ;; we need baking to allow recompilation which it doesnt 12 | ;; yet (as it turns the stages into lambda) 13 | 14 | ;;------------------------------------------------------------ 15 | ;; 16 | 17 | (defvar *pgraph-blend-params* 18 | (make-blending-params 19 | :mode-rgb :func-add 20 | :mode-alpha :func-add 21 | :source-rgb :one 22 | :destination-rgb :one 23 | :source-alpha :one 24 | :destination-alpha :one)) 25 | 26 | ;;------------------------------------------------------------ 27 | 28 | (defun-g pgraph-billboard-range-vert ((vert g-pt) 29 | &uniform 30 | (func (function (:float) :vec3)) 31 | (min :float) 32 | (by :float) 33 | (projection :mat4) 34 | (point-size :float)) 35 | (with-slots (position texture) vert 36 | (let* ((input (+ min (* by (float gl-instance-id)))) 37 | (func-result (funcall func input)) 38 | (world-pos (vec4 (+ (* position point-size) 39 | func-result) 40 | 1.0))) 41 | (values 42 | (* projection world-pos) 43 | texture)))) 44 | 45 | (defun-g pgraph-dot-frag ((uv :vec2) 46 | &uniform 47 | (point-color :vec4)) 48 | (let ((sdf-scale 5f0)) 49 | (mix 50 | (v! 0 0 0 0) 51 | point-color 52 | (nineveh.sdf.2d:mask-fill 53 | (nineveh.sdf.2d:circle (* uv 2 sdf-scale) sdf-scale)))) 54 | (v! 1 0 0 0)) 55 | 56 | (defpipeline-g pgraph-billboard-range () 57 | :vertex (pgraph-billboard-range-vert g-pt) 58 | :fragment (pgraph-dot-frag :vec2)) 59 | 60 | ;;------------------------------------------------------------ 61 | 62 | (defgeneric pgraph (pipeline position-vec3 direction-vec3 &key)) 63 | 64 | ;; {TODO} when rtg-math has desctructive projection funcs store 65 | ;; a mat4 in this struct 66 | (defstruct (pgraph-base-pipeline (:constructor nil)) 67 | (pipeline (error "BUG: pgraph-range with no inner pipeline") 68 | :type function) 69 | (quad (error "BUG: pgraph-range with no inner quad") 70 | :type buffer-stream)) 71 | 72 | (defmethod free ((obj pgraph-base-pipeline)) 73 | ;; quad is owned by nineveh internals so we dont free it 74 | (free (pgraph-base-pipeline-pipeline obj))) 75 | 76 | ;;------------------------------------------------------------ 77 | 78 | (defstruct (pgraph-range-pipeline (:include pgraph-base-pipeline) 79 | (:constructor %pgraph-range))) 80 | 81 | (defun make-pgraph-range-pipeline (gpu-function) 82 | (let ((quad (nineveh.internals:get-gpu-quad)) 83 | (cpipeline (bake-uniforms 'pgraph-billboard-range 84 | :func gpu-function))) 85 | (%pgraph-range 86 | :pipeline cpipeline 87 | :quad quad))) 88 | 89 | (defmethod pgraph ((pipeline pgraph-range-pipeline) 90 | position-vec3 91 | direction-vec3 92 | &key (min 0f0) (max 100f0) (by 1f0) 93 | (point-color (vec4 0.7 0.7 0.8 0.0)) 94 | (point-size 1f0)) 95 | (let* ((cpipeline (pgraph-range-pipeline-pipeline pipeline)) 96 | (min (float min 0f0)) 97 | (max (float max 0f0)) 98 | (by (float by 0f0)) 99 | (point-size (float point-size 0f0)) 100 | (count (floor (/ (- max min) by))) 101 | (vp (current-viewport)) 102 | (proj (rtg-math.projection:perspective 103 | (float (viewport-resolution-x vp) 0f0) 104 | (float (viewport-resolution-y vp) 0f0) 105 | 1f0 106 | 1000f0 107 | 45f0)) 108 | (stream (pgraph-range-pipeline-quad pipeline))) 109 | (declare (type function cpipeline)) 110 | (with-setf (depth-test-function) nil 111 | (with-blending *pgraph-blend-params* 112 | (with-instances count 113 | (map-g cpipeline stream 114 | :projection proj 115 | :min min 116 | :by by 117 | :point-color point-color 118 | :point-size point-size)))))) 119 | 120 | ;;------------------------------------------------------------ 121 | 122 | #+nil 123 | (defun-g blep ((i :float)) 124 | (let ((ang (* i 0.1))) 125 | (* (vec3 (sin ang) (cos ang) -5) 126 | (* i 0.001)))) 127 | 128 | #+nil 129 | (defun-g glap ((i :float)) 130 | (let ((ang (* i 0.1))) 131 | (* (vec2 (sin ang) (cos ang)) 132 | (* i 0.001)))) 133 | 134 | ;; 135 | -------------------------------------------------------------------------------- /hashing/permutation-polynomial-hash.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.hashing) 2 | 3 | ;;------------------------------------------------------------ 4 | 5 | (defun-g qpp-coord-prepare ((x :vec4)) 6 | (mod-fixed-denominator x 289f0)) 7 | 8 | (defun-g qpp-coord-prepare ((x :vec3)) 9 | (mod-fixed-denominator x 289f0)) 10 | 11 | (defun-g qpp-permute ((x :vec4)) 12 | (* (fract (* x (+ (* (/ 34.0 289.0) x) (v4! (/ 1.0 289.0))))) 13 | 289.0)) 14 | 15 | (defun-g qpp-resolve ((x :vec4)) 16 | (fract (* x (/ 7.0 288.0)))) 17 | 18 | ;;------------------------------------------------------------ 19 | ;; 2D 20 | 21 | (defun-g sgim-qpp-hash ((grid-cell :vec2)) 22 | (let* ((hash-coord 23 | (qpp-coord-prepare 24 | (v! (s~ grid-cell :xy) (+ (s~ grid-cell :xy) (v2! 1.0)))))) 25 | (qpp-resolve 26 | (qpp-permute 27 | (+ (qpp-permute (s~ hash-coord :xzxz)) (s~ hash-coord :yyww)))))) 28 | 29 | (defun-g sgim-qpp-hash-2-per-corner ((grid-cell :vec2)) 30 | (let (((hash-0 :vec4)) ((hash-1 :vec4))) 31 | (let* ((hash-coord 32 | (qpp-coord-prepare 33 | (v! (s~ grid-cell :xy) (+ (s~ grid-cell :xy) (v2! 1.0)))))) 34 | (setf hash-0 35 | (qpp-permute 36 | (+ (qpp-permute (s~ hash-coord :xzxz)) (s~ hash-coord :yyww)))) 37 | (setf hash-1 (qpp-resolve (qpp-permute hash-0))) 38 | (setf hash-0 (qpp-resolve hash-0))) 39 | (values hash-0 hash-1))) 40 | 41 | ;;------------------------------------------------------------ 42 | ;; 3D 43 | 44 | (defun-g sgim-qpp-hash ((grid-cell :vec3)) 45 | (let (((lowz-hash :vec4)) ((highz-hash :vec4))) 46 | (progn 47 | (setf grid-cell (qpp-coord-prepare grid-cell)) 48 | (let* ((grid-cell-inc1 (* (step grid-cell (v3! 287.5)) 49 | (+ grid-cell (v3! 1.0))))) 50 | (setf highz-hash 51 | (qpp-permute 52 | (+ 53 | (qpp-permute 54 | (s~ (v2! (x grid-cell) (x grid-cell-inc1)) :xyxy)) 55 | (s~ (v2! (y grid-cell) (y grid-cell-inc1)) :xxyy)))) 56 | (setf lowz-hash 57 | (qpp-resolve 58 | (qpp-permute (+ highz-hash (s~ grid-cell :zzzz))))) 59 | (setf highz-hash 60 | (qpp-resolve 61 | (qpp-permute (+ highz-hash (s~ grid-cell-inc1 :zzzz))))))) 62 | (values lowz-hash highz-hash))) 63 | 64 | (defun-g sgim-qpp-hash-3-per-corner ((grid-cell :vec3) 65 | (v1-mask :vec3) 66 | (v2-mask :vec3)) 67 | (let (((hash-0 :vec4)) ((hash-1 :vec4)) ((hash-2 :vec4))) 68 | (let* ((coords0 69 | (- (s~ grid-cell :xyz) 70 | (* (floor (* (s~ grid-cell :xyz) (/ 1.0 289.0))) 289.0))) 71 | (coords3 (* (step coords0 (v3! 287.5)) (+ coords0 (v3! 1.0)))) 72 | (coords1 (mix coords0 coords3 v1-mask)) 73 | (coords2 (mix coords0 coords3 v2-mask))) 74 | (setf hash-2 75 | (qpp-permute 76 | (+ 77 | (qpp-permute 78 | (+ 79 | (qpp-permute 80 | (v4! (x coords0) (x coords1) (x coords2) (x coords3))) 81 | (v4! (y coords0) (y coords1) (y coords2) (y coords3)))) 82 | (v4! (z coords0) (z coords1) (z coords2) (z coords3))))) 83 | (setf hash-0 (qpp-resolve hash-2)) 84 | (setf hash-1 (qpp-resolve (setf hash-2 (qpp-permute hash-2)))) 85 | (setf hash-2 (qpp-resolve (qpp-permute hash-2)))) 86 | (values hash-0 hash-1 hash-2))) 87 | 88 | (defun-g sgim-qpp-hash-3-per-corner ((grid-cell :vec3)) 89 | (let (((lowz-hash-0 :vec4)) 90 | ((lowz-hash-1 :vec4)) 91 | ((lowz-hash-2 :vec4)) 92 | ((highz-hash-0 :vec4)) 93 | ((highz-hash-1 :vec4)) 94 | ((highz-hash-2 :vec4))) 95 | (progn 96 | (setf grid-cell (qpp-coord-prepare grid-cell)) 97 | (let* ((grid-cell-inc1 (* (step grid-cell (v3! 287.5)) 98 | (+ grid-cell (v3! 1.0))))) 99 | (setf highz-hash-2 100 | (qpp-permute 101 | (+ 102 | (qpp-permute 103 | (s~ (v2! (x grid-cell) (x grid-cell-inc1)) :xyxy)) 104 | (s~ (v2! (y grid-cell) (y grid-cell-inc1)) :xxyy)))) 105 | (setf lowz-hash-2 (qpp-permute (+ highz-hash-2 (s~ grid-cell :zzzz)))) 106 | (setf lowz-hash-0 (qpp-resolve lowz-hash-2)) 107 | (setf highz-hash-0 108 | (qpp-resolve 109 | (setf highz-hash-2 110 | (qpp-permute 111 | (+ highz-hash-2 (s~ grid-cell-inc1 :zzzz)))))) 112 | (setf lowz-hash-1 113 | (qpp-resolve (setf lowz-hash-2 (qpp-permute lowz-hash-2)))) 114 | (setf highz-hash-1 115 | (qpp-resolve (setf highz-hash-2 (qpp-permute highz-hash-2)))) 116 | (setf lowz-hash-2 (qpp-resolve (qpp-permute lowz-hash-2))) 117 | (setf highz-hash-2 (qpp-resolve (qpp-permute highz-hash-2))) 118 | (values lowz-hash-0 lowz-hash-1 lowz-hash-2 highz-hash-0 highz-hash-1 119 | highz-hash-2))))) 120 | 121 | ;;------------------------------------------------------------ 122 | -------------------------------------------------------------------------------- /streams/buffer-streamer.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.streams) 2 | 3 | ;; Based on the wonderful article from here: Jonathan Dupuy 4 | ;; 5 | ;; http://onrendering.blogspot.no/2011/10/buffer-object-streaming-in-opengl.html 6 | 7 | ;; {TODO} the is a lot of accessing non exported symbols in here. This means 8 | ;; that CEPL is not exposing everything user's need. Revisit CEPL and 9 | ;; see how to help users use the 'make before gl-context' stuff. 10 | 11 | (defstruct (buffer-streamer (:include buffer-stream) 12 | (:constructor %make-buffer-streamer)) 13 | (arr (error "buffer-streamer: bug[0]") 14 | :type cepl.types::gpu-array-bb)) 15 | 16 | (defmethod print-object ((object buffer-streamer) stream) 17 | (let ((arr (buffer-streamer-arr object))) 18 | (format stream "#<~a (~s) ~s :LENGTH ~s>" 19 | 'buffer-streamer 20 | (buffer-stream-vao object) 21 | (gpu-array-element-type arr) 22 | (first (gpu-array-dimensions arr))))) 23 | 24 | (defun make-buffer-streamer (dimensions element-type 25 | &optional (primitive :triangles)) 26 | (when (listp dimensions) 27 | (assert (= (length dimensions) 1))) 28 | (assert element-type) 29 | (let* ((len (first (ensure-list dimensions))) 30 | (array (make-gpu-array nil :element-type element-type 31 | :dimensions len 32 | :access-style :stream-draw)) 33 | (gpu-arrays (list array))) 34 | (cepl.context::if-gl-context 35 | (%init-streamer 36 | (cepl.streams::init-buffer-stream-from-id 37 | %pre% (cepl.vaos:make-vao gpu-arrays) 38 | gpu-arrays nil 0 len 0 t)) 39 | (make-uninitialized-streamer primitive) 40 | gpu-arrays))) 41 | 42 | (defun %init-streamer (streamer) 43 | (setf (buffer-streamer-arr streamer) 44 | (caar (buffer-stream-gpu-arrays streamer))) 45 | streamer) 46 | 47 | (defun make-uninitialized-streamer (primitive) 48 | (let* ((prim (varjo.internals:primitive-name-to-instance primitive)) 49 | (prim-group-id (%cepl.types::draw-mode-group-id prim)) 50 | (enum-kwd (varjo::lisp-name prim)) 51 | (enum-val (cffi:foreign-enum-value '%gl:enum enum-kwd :errorp t)) 52 | (patch-length (if (typep prim 'varjo::patches) 53 | (varjo::vertex-count prim) 54 | 0))) 55 | (%make-buffer-streamer 56 | :vao 0 57 | :%start 0 58 | :%start-byte 0 59 | :length 0 60 | :%index-type-enum 0 61 | :%index-type-size 0 62 | :managed t 63 | :%primitive enum-kwd 64 | :primitive-group-id prim-group-id 65 | :draw-mode-val enum-val 66 | :patch-length patch-length 67 | :arr cepl.types::+null-buffer-backed-gpu-array+ 68 | :gpu-arrays nil))) 69 | 70 | (defn buffer-streamer-push-from-range ((c-array c-array) 71 | (streamer buffer-streamer) 72 | (c-array-start c-array-index) 73 | (c-array-end c-array-index) 74 | &optional new-primitive) 75 | buffer-streamer 76 | (declare (optimize (speed 3) (safety 1) (debug 1) (compilation-speed 0)) 77 | (inline gpu-array-element-type) 78 | (profile t) 79 | #+sbcl(sb-ext:muffle-conditions sb-ext:compiler-note)) 80 | (assert (= (length (c-array-dimensions c-array)) 1)) 81 | (assert (<= c-array-end (c-array-total-size c-array))) 82 | (let* ((g-arr (buffer-streamer-arr streamer)) 83 | (g-len (first (gpu-array-dimensions g-arr))) 84 | (c-len c-array-end) 85 | (s-start (cepl.streams::buffer-stream-start streamer)) 86 | (s-len (buffer-stream-length streamer)) 87 | (old-tail-pos (coerce (+ s-start s-len) '(unsigned-byte 64))) 88 | (doesnt-wrap (< (+ old-tail-pos c-len) g-len)) 89 | (new-start-pos (if doesnt-wrap 90 | old-tail-pos 91 | 0))) 92 | (assert (equal (c-array-element-type c-array) 93 | (gpu-array-element-type g-arr))) 94 | (unless doesnt-wrap 95 | (reallocate-gpu-array g-arr) 96 | (cepl.vaos:make-vao-from-id (buffer-stream-vao streamer) (list g-arr))) 97 | 98 | (setf (cepl.streams::buffer-stream-start streamer) new-start-pos 99 | (cepl.streams:buffer-stream-length streamer) c-len) 100 | 101 | (when new-primitive 102 | (setf (cepl.streams:buffer-stream-primitive streamer) new-primitive)) 103 | 104 | (let ((c-ptr (cepl.c-arrays::ptr-index-1d c-array c-array-start))) 105 | (cepl.gpu-arrays::with-gpu-array-range-as-pointer 106 | (g-ptr g-arr new-start-pos c-len 107 | :access-set '(:map-write :map-unsynchronized)) 108 | (cepl.types::%memcpy g-ptr c-ptr 109 | (* (cepl.c-arrays::c-array-element-byte-size c-array) 110 | c-len)))) 111 | streamer)) 112 | 113 | (defn buffer-streamer-push ((c-array c-array) 114 | (streamer buffer-streamer) 115 | &optional new-primitive) 116 | buffer-streamer 117 | (buffer-streamer-push-from-range 118 | c-array streamer 0 (first (c-array-dimensions c-array)) new-primitive)) 119 | 120 | (defmethod push-g ((c-arr c-array) (destination buffer-streamer)) 121 | (buffer-streamer-push c-arr destination)) 122 | 123 | (defmethod push-g ((object list) (destination buffer-streamer)) 124 | (let ((garr (buffer-streamer-arr destination))) 125 | (with-c-array-freed (tmp (make-c-array object 126 | :dimensions (length object) 127 | :element-type (element-type garr))) 128 | (push-g tmp destination)))) 129 | 130 | (defmethod push-g ((object array) (destination buffer-streamer)) 131 | (let ((garr (buffer-streamer-arr destination))) 132 | (with-c-array-freed (tmp (make-c-array object 133 | :dimensions (length object) 134 | :element-type (element-type garr))) 135 | (push-g tmp destination)))) 136 | -------------------------------------------------------------------------------- /mesh/data/primitives.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.mesh.data.primitives) 2 | 3 | ;;------------------------------------------------------------ 4 | 5 | (defmacro %c-array-internals ((index-type normals-p tex-coords-p) 6 | &body call) 7 | (assert (= (length call) 1)) 8 | (alexandria:with-gensyms (indx-type norms-p uvs-p) 9 | `(dbind (data-ptr data-len indices-ptr index-len) ,(first call) 10 | (let* ((,uvs-p ,tex-coords-p) 11 | (,norms-p ,normals-p) 12 | (elem-type (cond 13 | ((and ,norms-p ,uvs-p) 'g-pnt) 14 | (,uvs-p 'g-pt) 15 | (,norms-p 'g-pn))) 16 | (elem-size (+ 3 (if ,norms-p 3 0) (if ,uvs-p 2 0))) 17 | (,indx-type ,index-type)) 18 | (list (make-c-array-from-pointer 19 | (/ data-len elem-size) elem-type data-ptr) 20 | (make-c-array-from-pointer 21 | index-len ,indx-type indices-ptr)))))) 22 | 23 | (defmacro %gpu-array-internals (call) 24 | `(dbind (data-c-array indices-c-array) ,call 25 | (prog1 (list (make-gpu-array data-c-array) 26 | (make-gpu-array indices-c-array)) 27 | (free data-c-array) 28 | (free indices-c-array)))) 29 | 30 | ;;------------------------------------------------------------ 31 | 32 | (defun lattice-c-arrays (&key (width 1.0) (height 1.0) (x-segments 30) 33 | (y-segments 30) (normals t) (tex-coords t)) 34 | (%c-array-internals (:uint normals tex-coords) 35 | (lattice-foreign 36 | :width width :height height 37 | :x-segments x-segments :y-segments y-segments 38 | :normals normals :tex-coords tex-coords))) 39 | 40 | (defun lattice-gpu-arrays (&key (width 1.0) (height 1.0) (x-segments 30) 41 | (y-segments 30) (normals t) (tex-coords t)) 42 | (%gpu-array-internals 43 | (lattice-c-arrays :width width :height height 44 | :x-segments x-segments :y-segments y-segments 45 | :normals normals :tex-coords tex-coords))) 46 | 47 | ;;------------------------------------------------------------ 48 | 49 | (defun box-c-arrays (&key (width 1.0) (height 1.0) (depth 1.0) 50 | (normals t) (tex-coords t)) 51 | (%c-array-internals (:ushort normals tex-coords) 52 | (box-foreign 53 | :width width :height height :depth depth 54 | :normals normals :tex-coords tex-coords))) 55 | 56 | (defun box-gpu-arrays (&key (width 1.0) (height 1.0) (depth 1.0) 57 | (normals t) (tex-coords t)) 58 | (%gpu-array-internals 59 | (box-c-arrays 60 | :width width :height height :depth depth 61 | :normals normals :tex-coords tex-coords))) 62 | 63 | ;;------------------------------------------------------------ 64 | 65 | (defun cone-c-arrays (&key (segments 30) (height 1) (radius 0.5f0) 66 | (normals t) (tex-coords t) (cap t)) 67 | (%c-array-internals (:ushort normals tex-coords) 68 | (cone-foreign :segments segments :height height :radius radius 69 | :normals normals :tex-coords tex-coords :cap cap))) 70 | 71 | (defun cone-gpu-arrays (&key (segments 30) (height 1) (radius 0.5f0) 72 | (normals t) (tex-coords t) (cap t)) 73 | (%gpu-array-internals 74 | (cone-c-arrays :segments segments :height height :radius radius 75 | :normals normals :tex-coords tex-coords :cap cap))) 76 | 77 | ;;------------------------------------------------------------ 78 | 79 | (defun cylinder-c-arrays (&key (segments 30) (height 1) (radius 0.5f0) 80 | (normals t) (tex-coords t) (cap t)) 81 | (%c-array-internals (:ushort normals tex-coords) 82 | (cylinder-foreign :segments segments :height height :radius radius 83 | :normals normals :tex-coords tex-coords :cap cap))) 84 | 85 | (defun cylinder-gpu-arrays (&key (segments 30) (height 1) (radius 0.5f0) 86 | (normals t) (tex-coords t) (cap t)) 87 | (%gpu-array-internals 88 | (cylinder-c-arrays :segments segments :height height :radius radius 89 | :normals normals :tex-coords tex-coords :cap cap))) 90 | 91 | ;;------------------------------------------------------------ 92 | 93 | (defun sphere-c-arrays (&key (radius 0.5) (lines-of-latitude 30) 94 | (lines-of-longitude 30) (normals t) (tex-coords t)) 95 | (%c-array-internals (:ushort normals tex-coords) 96 | (sphere-foreign 97 | :radius radius :lines-of-longitude lines-of-longitude 98 | :lines-of-latitude lines-of-latitude 99 | :normals normals :tex-coords tex-coords))) 100 | 101 | (defun sphere-gpu-arrays (&key (radius 0.5) (lines-of-latitude 30) 102 | (lines-of-longitude 30) (normals t) (tex-coords t)) 103 | (%gpu-array-internals 104 | (sphere-c-arrays 105 | :radius radius :lines-of-longitude lines-of-longitude 106 | :lines-of-latitude lines-of-latitude 107 | :normals normals :tex-coords tex-coords))) 108 | 109 | ;;------------------------------------------------------------ 110 | 111 | (defun plain-gpu-arrays (&key (width 1.0) (height 1.0) (normals t) 112 | (tex-coords t)) 113 | (lattice-gpu-arrays :width width :height height 114 | :x-segments 1 :y-segments 1 115 | :normals normals :tex-coords tex-coords)) 116 | 117 | (defun plain-c-arrays (&key (width 1.0) (height 1.0) (normals t) 118 | (tex-coords t)) 119 | (lattice-c-arrays :width width :height height 120 | :x-segments 1 :y-segments 1 121 | :normals normals :tex-coords tex-coords)) 122 | 123 | ;;------------------------------------------------------------ 124 | 125 | (defun cube-gpu-arrays (&key (size 1.0) (normals t) (tex-coords t)) 126 | (box-gpu-arrays :width size :height size :depth size :normals normals 127 | :tex-coords tex-coords)) 128 | 129 | 130 | (defun cube-c-arrays (&key (size 1.0) (normals t) (tex-coords t)) 131 | (box-c-arrays :width size :height size :depth size :normals normals 132 | :tex-coords tex-coords)) 133 | 134 | ;;------------------------------------------------------------ 135 | -------------------------------------------------------------------------------- /color/color-space-conversions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.color) 2 | 3 | ;;------------------------------------------------------------ 4 | ;; 5 | ;; Props to http://blog.demofox.org/2014/02/03/converting-rgb-to-grayscale/ 6 | ;; for the clear explanation of the formula and why it's needed 7 | ;; 8 | ;;------------------------------------------------------------ 9 | 10 | (defun-g rgb->greyscale ((rgb :vec3)) 11 | (+ (* (x rgb) 0.3) 12 | (* (y rgb) 0.59) 13 | (* (z rgb) 0.11))) 14 | 15 | ;;------------------------------------------------------------ 16 | ;; 17 | ;; Mad ♥ to Ian Taylor of http://www.chilliant.com 18 | ;; Sam Hocevar of http://lolengine.net 19 | ;; and Emil Persson of http://www.humus.name/ 20 | ;; for doing all the hard work of bringing the following functions to life at 21 | ;; http://www.chilliant.com/rgb2hsv.html 22 | ;; 23 | ;;------------------------------------------------------------ 24 | 25 | (defconstant +hcx-epsilon+ 1e-10) 26 | 27 | ;; --- Hue --- 28 | 29 | (defun-g hue->rgb ((hue :float)) 30 | (saturate 31 | (v! (- (abs (- (* hue 6) 3)) 1) 32 | (- 2 (abs (- (* hue 6) 2))) 33 | (- 2 (abs (- (* hue 6) 4)))))) 34 | 35 | ;; --- HCV --- 36 | 37 | (defun-g rgb->hcv ((rgb :vec3)) 38 | (let* ( 39 | (p (if (< (y rgb) (z rgb)) 40 | (v! (s~ rgb :zy) (- 1.0) (/ 2.0 3.0)) 41 | (v! (s~ rgb :yz) 0.0 (/ (- 1.0) 3.0)))) 42 | (q (if (< (x rgb) (x p)) 43 | (v! (s~ p :xyw) (x rgb)) 44 | (v! (x rgb) (s~ p :yzx)))) 45 | (c (- (x q) 46 | (min (w q) (y q)))) 47 | (h (abs (+ (/ (- (w q) (y q)) 48 | (+ (* 6 c) +hcx-epsilon+)) 49 | (z q))))) 50 | (v! h c (x q)))) 51 | 52 | ;; --- HSV --- 53 | 54 | (defun-g rgb->hsv ((rgb :vec3)) 55 | (let* ((hcv (rgb->hcv rgb)) 56 | (s (/ (y hcv) 57 | (+ (z hcv) +hcx-epsilon+)))) 58 | (v! (x hcv) s (z hcv)))) 59 | 60 | (defun-g hsv->rgb ((hsv :vec3)) 61 | (let* ((rgb (hue->rgb (x hsv)))) 62 | (* (+ (* (- rgb (v3! 1f0)) (y hsv)) (v3! 1f0)) 63 | (z hsv)))) 64 | 65 | ;; --- HSL --- 66 | 67 | (defun-g rgb->hsl ((rgb :vec3)) 68 | (let* ((hcv (rgb->hcv rgb)) 69 | (l (- (z hcv) (* (y hcv) 0.5))) 70 | (s (/ (y hcv) (- 1 (+ (abs (- (* l 2) 1)) 71 | +hcx-epsilon+))))) 72 | (v! (x hcv) s l))) 73 | 74 | (defun-g hsl->rgb ((hsl :vec3)) 75 | (let* ((rgb (hue->rgb (x hsl))) 76 | (c (* (- (v3! 1) 77 | (v3! (abs (- (* 2f0 (z hsl)) 1f0)))) 78 | (y hsl)))) 79 | (+ (* (- rgb (v3! 0.5)) c) 80 | (v3! (z hsl))))) 81 | 82 | ;; --- HCY --- 83 | 84 | (defun-g rgb->hcy ((rgb :vec3)) 85 | (let* ((hcy-wts (v! 0.299 0.587 0.114)) 86 | (hcv (rgb->hcv rgb)) 87 | (y (dot rgb hcy-wts)) 88 | (z 89 | (dot (hue->rgb (x hcv)) 90 | hcy-wts))) 91 | (if (< y z) 92 | (multf (y hcv) 93 | (/ z (+ +hcx-epsilon+ y))) 94 | (multf (y hcv) 95 | (/ (- 1 z) 96 | (- (+ +hcx-epsilon+ 1) y)))) 97 | (v! (x hcv) (y hcv) y))) 98 | 99 | (defun-g hcy->rgb ((hcy :vec3)) 100 | (let* ((hcy-wts (v! 0.299 0.587 0.114)) 101 | (rgb (hue->rgb (x hcy))) 102 | (z (dot rgb hcy-wts))) 103 | (if (< (z hcy) z) 104 | (multf (y hcy) (/ (z hcy) z)) 105 | (when (< z 1) 106 | (multf (y hcy) (/ (- 1 (z hcy)) (- 1 z))))) 107 | (+ (* (- rgb (v3! z)) (y hcy)) 108 | (v3! (z hcy))))) 109 | 110 | ;; --- HCL --- 111 | 112 | (defun-g rgb->hcl ((rgb :vec3)) 113 | (let* ((hcl-gamma 3f0) 114 | (hcl (v3! 0)) 115 | (hcl-y0 100f0) 116 | (hclmax-l "0.530454533953517") 117 | (h 0f0) 118 | (u (min (x rgb) (min (y rgb) (z rgb)))) 119 | (v (max (x rgb) (max (y rgb) (z rgb)))) 120 | (q (/ hcl-gamma hcl-y0))) 121 | (setf (y hcl) (- v u)) 122 | (when (/= (y hcl) 0) 123 | (setf h (/ (atan (- (x rgb) (y rgb)) (- (y rgb) (z rgb))) pi-f)) 124 | (multf q (/ u v))) 125 | (setf q (exp q)) 126 | (setf (x hcl) (fract (- (/ h 2) (/ (min (fract h) (fract (- h))) 6)))) 127 | (multf (y hcl) q) 128 | (setf (z hcl) (/ (mix (- u) v q) (* hclmax-l 2))) 129 | hcl)) 130 | 131 | ;; Compiles to bad glsl - 132 | ;; (defun-g hcl->rgb ((hcl :vec3)) 133 | ;; (let* ((hcl-gamma 3f0) 134 | ;; (hcl-y0 100f0) 135 | ;; (hclmax-l "0.530454533953517") 136 | ;; (rgb (v3! 0))) 137 | ;; (when (/= (z hcl) 0) 138 | ;; (let* ((h (x hcl)) 139 | ;; (c (y hcl)) 140 | ;; (l (* (z hcl) hclmax-l)) 141 | ;; (q (exp (* (- 1 (/ c (* 2 l))) (/ hcl-gamma hcl-y0)))) 142 | ;; (u (/ (- (* 2 l) c) (- (* 2 q) 1))) 143 | ;; (v (/ c q)) 144 | ;; (tx 145 | ;; (tan 146 | ;; (* (+ h (min (/ (fract (* 2 h)) 4) (/ (fract (* (- 2) h)) 8))) 147 | ;; (* pi-f 2))))) 148 | ;; (multf h 6f0) 149 | ;; (cond 150 | ;; ((<= h 1f0) 151 | ;; (setf (x rgb) 1f0) 152 | ;; (setf (y rgb) (/ tx (+ 1f0 tx))) 153 | ;; (values)) 154 | ;; ((<= h 2) 155 | ;; (setf (x rgb) (/ (+ 1f0 tx) tx)) 156 | ;; (setf (y rgb) 1f0) 157 | ;; (values)) 158 | ;; ((<= h 3) 159 | ;; (setf (y rgb) 1f0) 160 | ;; (setf (z rgb) (+ 1f0 tx)) 161 | ;; (values)) 162 | ;; ((<= h 4) 163 | ;; (setf (y rgb) (/ 1f0 (+ 1f0 tx))) 164 | ;; (setf (z rgb) 1f0) 165 | ;; (values)) 166 | ;; ((<= h 5) 167 | ;; (setf (x rgb) (/ (- 1f0) tx)) 168 | ;; (setf (z rgb) 1f0) 169 | ;; (values)) 170 | ;; (t 171 | ;; (setf (x rgb) 1f0) 172 | ;; (setf (z rgb) (- tx)) 173 | ;; (values))) 174 | ;; (setf rgb (+ (* rgb v) (v3! u))))) 175 | ;; rgb)) 176 | 177 | ;;------------------------------------------------------------ 178 | ;; http://lolengine.net/blog/2013/07/27/rgb-to-hsv-in-glsl is also worth reading 179 | ;; The site seems worryingly slow so in-case it has gone here is the wayback 180 | ;; version: https://web.archive.org/web/20161105155520/http://lolengine.net/blog/2013/07/27/rgb-to-hsv-in-glsl 181 | ;;------------------------------------------------------------ 182 | -------------------------------------------------------------------------------- /hashing/bsharpe-quick32-hash.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.hashing) 2 | 3 | ;; 4 | ;; bs-quick32-hash (known in Brian's work as FastHash32_2) 5 | ;; 6 | ;; An alternative to FastHash32 7 | ;; - slightly slower 8 | ;; - can have a larger domain 9 | ;; - allows for a 4D implementation 10 | ;; 11 | 12 | ;;------------------------------------------------------------ 13 | ;; 2D 14 | 15 | (defun-g bs-quick32-hash ((grid-cell :vec2)) 16 | (let* ((offset (glsl-expr "vec2(403.839172, 377.242706)" :vec2)) 17 | (domain 69.0) 18 | (somelargefloat (glsl-expr "32745.708984" :float)) 19 | (scale (glsl-expr "vec2(2.009842, 1.372549)" :vec2)) 20 | (p (v! (s~ grid-cell :xy) (+ (s~ grid-cell :xy) (v2! 1.0))))) 21 | (setf p (- p (* (floor (* p (/ 1.0 domain))) domain))) 22 | (setf p (+ (* p (s~ scale :xyxy)) (s~ offset :xyxy))) 23 | (multf p p) 24 | (fract (* (s~ p :xzxz) (* (s~ p :yyww) (/ 1.0 somelargefloat)))))) 25 | 26 | ;;------------------------------------------------------------ 27 | ;; 3D 28 | 29 | (defun-g bs-quick32-hash ((grid-cell :vec3)) 30 | (let (((z0-hash :vec4)) ((z1-hash :vec4))) 31 | (let* ((offset (glsl-expr "vec3(55.882355, 63.167774, 52.941177)" :vec3)) 32 | (domain 69.0) 33 | (somelargefloat (glsl-expr "69412.070313" :float)) 34 | (scale (glsl-expr "vec3(0.235142, 0.205890, 0.216449)" :vec3))) 35 | (setf grid-cell 36 | (- grid-cell (* (floor (* grid-cell (/ 1.0 domain))) domain))) 37 | (let* ((grid-cell-inc1 38 | (* (step grid-cell (v3! (- domain 1.5))) (+ grid-cell (v3! 1.0))))) 39 | (setf grid-cell (+ (* grid-cell scale) offset)) 40 | (setf grid-cell-inc1 (+ (* grid-cell-inc1 scale) offset)) 41 | (multf grid-cell grid-cell) 42 | (multf grid-cell-inc1 grid-cell-inc1) 43 | (let* ((x0y0-x1y0-x0y1-x1y1 44 | (* 45 | (v4! (x grid-cell) (x grid-cell-inc1) (x grid-cell) 46 | (x grid-cell-inc1)) 47 | (v! (s~ grid-cell :yy) (s~ grid-cell-inc1 :yy))))) 48 | (setf z0-hash 49 | (fract 50 | (* x0y0-x1y0-x0y1-x1y1 51 | (* (s~ grid-cell :zzzz) (/ 1.0 somelargefloat))))) 52 | (setf z1-hash 53 | (fract 54 | (* x0y0-x1y0-x0y1-x1y1 55 | (* (s~ grid-cell-inc1 :zzzz) 56 | (/ 1.0 somelargefloat)))))))) 57 | (values z0-hash z1-hash))) 58 | 59 | ;;------------------------------------------------------------ 60 | ;; 4D 61 | 62 | (defun-g bs-quick32-hash ((grid-cell :vec4)) 63 | (let (((z0w0-hash :vec4)) 64 | ((z1w0-hash :vec4)) 65 | ((z0w1-hash :vec4)) 66 | ((z1w1-hash :vec4))) 67 | (let* ((offset (glsl-expr "vec4(16.84123, 18.774548, 16.873274, 13.664607)" 68 | :vec4)) 69 | (domain 69.0) 70 | (somelargefloat (glsl-expr "47165.636719" :float)) 71 | (scale (glsl-expr "vec4(0.102007, 0.114473, 0.139651, 0.084550)" 72 | :vec4))) 73 | (setf grid-cell 74 | (- grid-cell (* (floor (* grid-cell (/ 1.0 domain))) domain))) 75 | (let* ((grid-cell-inc1 76 | (* (step grid-cell (v4! (- domain 1.5))) (+ grid-cell (v4! 1.0))))) 77 | (setf grid-cell (+ (* grid-cell scale) offset)) 78 | (setf grid-cell-inc1 (+ (* grid-cell-inc1 scale) offset)) 79 | (multf grid-cell grid-cell) 80 | (multf grid-cell-inc1 grid-cell-inc1) 81 | (let* ((x0y0-x1y0-x0y1-x1y1 82 | (* 83 | (v4! (x grid-cell) (x grid-cell-inc1) (x grid-cell) 84 | (x grid-cell-inc1)) 85 | (v! (s~ grid-cell :yy) (s~ grid-cell-inc1 :yy)))) 86 | (z0w0-z1w0-z0w1-z1w1 87 | (* 88 | (v4! (z grid-cell) (z grid-cell-inc1) (z grid-cell) 89 | (z grid-cell-inc1)) 90 | (* (v! (s~ grid-cell :ww) (s~ grid-cell-inc1 :ww)) 91 | (/ 1.0 somelargefloat))))) 92 | (setf z0w0-hash 93 | (fract 94 | (* x0y0-x1y0-x0y1-x1y1 (s~ z0w0-z1w0-z0w1-z1w1 :xxxx)))) 95 | (setf z1w0-hash 96 | (fract 97 | (* x0y0-x1y0-x0y1-x1y1 (s~ z0w0-z1w0-z0w1-z1w1 :yyyy)))) 98 | (setf z0w1-hash 99 | (fract 100 | (* x0y0-x1y0-x0y1-x1y1 (s~ z0w0-z1w0-z0w1-z1w1 :zzzz)))) 101 | (setf z1w1-hash 102 | (fract 103 | (* x0y0-x1y0-x0y1-x1y1 (s~ z0w0-z1w0-z0w1-z1w1 :wwww))))))) 104 | (values z0w0-hash z1w0-hash z0w1-hash z1w1-hash))) 105 | 106 | (defun-g bs-quick32-hash-4-per-corner ((grid-cell :vec4)) 107 | (let (((z0w0-hash-0 :vec4)) 108 | ((z0w0-hash-1 :vec4)) 109 | ((z0w0-hash-2 :vec4)) 110 | ((z0w0-hash-3 :vec4)) 111 | ((z1w0-hash-0 :vec4)) 112 | ((z1w0-hash-1 :vec4)) 113 | ((z1w0-hash-2 :vec4)) 114 | ((z1w0-hash-3 :vec4)) 115 | ((z0w1-hash-0 :vec4)) 116 | ((z0w1-hash-1 :vec4)) 117 | ((z0w1-hash-2 :vec4)) 118 | ((z0w1-hash-3 :vec4)) 119 | ((z1w1-hash-0 :vec4)) 120 | ((z1w1-hash-1 :vec4)) 121 | ((z1w1-hash-2 :vec4)) 122 | ((z1w1-hash-3 :vec4))) 123 | (let* ((offset (glsl-expr "vec4(16.84123, 18.774548, 16.873274, 13.664607)" 124 | :vec4)) 125 | (domain 69.0) 126 | (some-large-floats 127 | (glsl-expr "vec4(56974.746094, 47165.636719, 55049.667969, 49901.273438)" 128 | :vec4)) 129 | (scale (glsl-expr "vec4(0.102007, 0.114473, 0.139651, 0.084550)" 130 | :vec4))) 131 | (setf grid-cell 132 | (- grid-cell (* (floor (* grid-cell (/ 1.0 domain))) domain))) 133 | (let* ((grid-cell-inc1 134 | (* (step grid-cell (v4! (- domain 1.5))) (+ grid-cell (v4! 1.0))))) 135 | (setf grid-cell (+ (* grid-cell scale) offset)) 136 | (setf grid-cell-inc1 (+ (* grid-cell-inc1 scale) offset)) 137 | (multf grid-cell grid-cell) 138 | (multf grid-cell-inc1 grid-cell-inc1) 139 | (let* ((x0y0-x1y0-x0y1-x1y1 140 | (* 141 | (v4! (x grid-cell) (x grid-cell-inc1) (x grid-cell) 142 | (x grid-cell-inc1)) 143 | (v! (s~ grid-cell :yy) (s~ grid-cell-inc1 :yy)))) 144 | (z0w0-z1w0-z0w1-z1w1 145 | (* 146 | (v4! (z grid-cell) (z grid-cell-inc1) (z grid-cell) 147 | (z grid-cell-inc1)) 148 | (v! (s~ grid-cell :ww) (s~ grid-cell-inc1 :ww)))) 149 | (hashval (* x0y0-x1y0-x0y1-x1y1 (s~ z0w0-z1w0-z0w1-z1w1 :xxxx)))) 150 | (setf z0w0-hash-0 (fract (* hashval (/ 1.0 (x some-large-floats))))) 151 | (setf z0w0-hash-1 (fract (* hashval (/ 1.0 (y some-large-floats))))) 152 | (setf z0w0-hash-2 (fract (* hashval (/ 1.0 (z some-large-floats))))) 153 | (setf z0w0-hash-3 (fract (* hashval (/ 1.0 (w some-large-floats))))) 154 | (setf hashval 155 | (* x0y0-x1y0-x0y1-x1y1 (s~ z0w0-z1w0-z0w1-z1w1 :yyyy))) 156 | (setf z1w0-hash-0 (fract (* hashval (/ 1.0 (x some-large-floats))))) 157 | (setf z1w0-hash-1 (fract (* hashval (/ 1.0 (y some-large-floats))))) 158 | (setf z1w0-hash-2 159 | (fract (* hashval (/ 1.0 (z some-large-floats))))) 160 | (setf z1w0-hash-3 161 | (fract (* hashval (/ 1.0 (w some-large-floats))))) 162 | (setf hashval 163 | (* x0y0-x1y0-x0y1-x1y1 (s~ z0w0-z1w0-z0w1-z1w1 :zzzz))) 164 | (setf z0w1-hash-0 165 | (fract (* hashval (/ 1.0 (x some-large-floats))))) 166 | (setf z0w1-hash-1 167 | (fract (* hashval (/ 1.0 (y some-large-floats))))) 168 | (setf z0w1-hash-2 169 | (fract (* hashval (/ 1.0 (z some-large-floats))))) 170 | (setf z0w1-hash-3 171 | (fract (* hashval (/ 1.0 (w some-large-floats))))) 172 | (setf hashval 173 | (* x0y0-x1y0-x0y1-x1y1 (s~ z0w0-z1w0-z0w1-z1w1 :wwww))) 174 | (setf z1w1-hash-0 175 | (fract (* hashval (/ 1.0 (x some-large-floats))))) 176 | (setf z1w1-hash-1 177 | (fract (* hashval (/ 1.0 (y some-large-floats))))) 178 | (setf z1w1-hash-2 179 | (fract (* hashval (/ 1.0 (z some-large-floats))))) 180 | (setf z1w1-hash-3 181 | (fract 182 | (* hashval (/ 1.0 (w some-large-floats)))))))) 183 | (values z0w0-hash-0 z0w0-hash-1 z0w0-hash-2 z0w0-hash-3 z1w0-hash-0 184 | z1w0-hash-1 z1w0-hash-2 z1w0-hash-3 z0w1-hash-0 z0w1-hash-1 185 | z0w1-hash-2 z0w1-hash-3 z1w1-hash-0 z1w1-hash-1 z1w1-hash-2 186 | z1w1-hash-3))) 187 | 188 | ;;------------------------------------------------------------ 189 | -------------------------------------------------------------------------------- /shaping-functions/interpolation.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.shaping-functions) 2 | 3 | ;;------------------------------------------------------------ 4 | ;; 3x^2-2x^3 Hermine Curve. Same as SmoothStep() 5 | ;; As used by Perlin in Original Noise. 6 | 7 | (defun-g hermine ((x :float)) 8 | (* x (* x (- 3.0 (* 2.0 x))))) 9 | 10 | (defun-g hermine ((x :vec2)) 11 | (* x (* x (- (v2! 3.0) (* 2.0 x))))) 12 | 13 | (defun-g hermine ((x :vec3)) 14 | (* x (* x (- (v3! 3.0) (* 2.0 x))))) 15 | 16 | (defun-g hermine ((x :vec4)) 17 | (* x (* x (- (v4! 3.0) (* 2.0 x))))) 18 | 19 | 20 | ;; just use smoothstep, only here for completeness 21 | (defun-g hermine ((min :float) (max :float) (x :float)) 22 | (let ((val (clamp (/ (- x min) (- max min)) 0f0 1f0))) 23 | (* val (* val (- 3.0 (* 2.0 val)))))) 24 | 25 | (defun-g hermine ((min :float) (max :float) (x :vec2)) 26 | (let* ((max (v2! max)) 27 | (min (v2! min)) 28 | (val (clamp (/ (- x min) (- max min)) 0f0 1f0))) 29 | (* val (* val (- (v2! 3.0) (* 2.0 val)))))) 30 | 31 | (defun-g hermine ((min :float) (max :float) (x :vec3)) 32 | (let* ((max (v3! max)) 33 | (min (v3! min)) 34 | (val (clamp (/ (- x min) (- max min)) 0f0 1f0))) 35 | (* val (* val (- (v3! 3.0) (* 2.0 val)))))) 36 | 37 | (defun-g hermine ((min :float) (max :float) (x :vec4)) 38 | (let* ((max (v4! max)) 39 | (min (v4! min)) 40 | (val (clamp (/ (- x min) (- max min)) 0f0 1f0))) 41 | (* val (* val (- (v4! 3.0) (* 2.0 val)))))) 42 | 43 | ;;------------------------------------------------------------ 44 | ;; 6x^5-15x^4+10x^3 Quintic Curve. 45 | ;; As used by Perlin in Improved Noise: http://mrl.nyu.edu/~perlin/paper445.pdf 46 | 47 | (defun-g quintic ((x :float)) 48 | (* x (* x (* x (+ (* x (- (* x 6.0) 15.0)) 10.0))))) 49 | 50 | (defun-g quintic ((x :vec2)) 51 | (* x (* x (* x (+ (* x (- (* x 6.0) (v2! 15.0))) 52 | (v2! 10.0)))))) 53 | 54 | (defun-g quintic ((x :vec3)) 55 | (* x (* x (* x (+ (* x (- (* x 6.0) (v3! 15.0))) 56 | (v3! 10.0)))))) 57 | 58 | (defun-g quintic ((x :vec4)) 59 | (* x (* x (* x (+ (* x (- (* x 6.0) (v4! 15.0))) 60 | (v4! 10.0)))))) 61 | 62 | (defun-g quintic ((min :float) (max :float) (x :float)) 63 | (let ((val (clamp (/ (- x min) (- max min)) 0f0 1f0))) 64 | (* val (* val (* val (+ (* val (- (* val 6.0) 15.0)) 10.0)))))) 65 | 66 | (defun-g quintic ((min :float) (max :float) (x :vec2)) 67 | (let* ((max (v2! max)) 68 | (min (v2! min)) 69 | (val (clamp (/ (- x min) (- max min)) 0f0 1f0))) 70 | (* val (* val (* val (+ (* val (- (* val 6.0) (v2! 15.0))) 71 | (v2! 10.0))))))) 72 | 73 | (defun-g quintic ((min :float) (max :float) (x :vec3)) 74 | (let* ((max (v3! max)) 75 | (min (v3! min)) 76 | (val (clamp (/ (- x min) (- max min)) 0f0 1f0))) 77 | (* val (* val (* val (+ (* val (- (* val 6.0) (v3! 15.0))) 78 | (v3! 10.0))))))) 79 | 80 | (defun-g quintic ((min :float) (max :float) (x :vec4)) 81 | (let* ((max (v4! max)) 82 | (min (v4! min)) 83 | (val (clamp (/ (- x min) (- max min)) 0f0 1f0))) 84 | (* val (* val (* val (+ (* val (- (* val 6.0) (v4! 15.0))) 85 | (v4! 10.0))))))) 86 | 87 | ;;------------------------------------------------------------ 88 | 89 | (defun-g quintic-interp-and-deriv ((x :vec2)) 90 | (* (s~ x :xyxy) 91 | (* (s~ x :xyxy) 92 | (+ 93 | (* (s~ x :xyxy) 94 | (+ 95 | (* (s~ x :xyxy) 96 | (+ (* (s~ x :xyxy) (s~ (v2! 6.0 0.0) :xxyy)) 97 | (s~ (v2! (- 15.0) 30.0) :xxyy))) 98 | (s~ (v2! 10.0 (- 60.0)) :xxyy))) 99 | (s~ (v2! 0.0 30.0) :xxyy))))) 100 | 101 | (defun-g quintic-deriv ((x :vec3)) 102 | (* x (* x (+ (* x (- (* x 30.0) (v3! 60.0))) 103 | (v3! 30.0))))) 104 | 105 | 106 | ;;------------------------------------------------------------ 107 | ;; 7x^3-7x^4+x^7 108 | ;; Faster than Perlin Quintic. Not quite as good shape. 109 | 110 | (defun-g quintic-fast ((x :float)) 111 | (let* ((x3 (* x x x))) 112 | (* (+ 7.0 (* (- x3 7.0) x)) x3))) 113 | 114 | (defun-g quintic-fast ((x :vec2)) 115 | (let* ((x3 (* x x x))) 116 | (* (+ (v2! 7.0) (* (- x3 (v2! 7.0)) x)) x3))) 117 | 118 | (defun-g quintic-fast ((x :vec3)) 119 | (let* ((x3 (* x x x))) 120 | (* (+ (v3! 7.0) (* (- x3 (v3! 7.0)) x)) x3))) 121 | 122 | (defun-g quintic-fast ((x :vec4)) 123 | (let* ((x3 (* x x x))) 124 | (* (+ (v4! 7.0) (* (- x3 (v4! 7.0)) x)) x3))) 125 | 126 | 127 | (defun-g quintic-fast ((min :float) (max :float) (x :float)) 128 | (let* ((val (clamp (/ (- x min) (- max min)) 0f0 1f0)) 129 | (val³ (* val val val))) 130 | (* (+ 7.0 (* (- val³ 7.0) val)) val³))) 131 | 132 | (defun-g quintic-fast ((min :float) (max :float) (x :vec2)) 133 | (let* ((max (v2! max)) 134 | (min (v2! min)) 135 | (val (clamp (/ (- x min) (- max min)) 0f0 1f0)) 136 | (val³ (* val val val))) 137 | (* (+ (v2! 7.0) (* (- val³ (v2! 7.0)) val)) val³))) 138 | 139 | (defun-g quintic-fast ((min :float) (max :float) (x :vec3)) 140 | (let* ((max (v3! max)) 141 | (min (v3! min)) 142 | (val (clamp (/ (- x min) (- max min)) 0f0 1f0)) 143 | (val³ (* val val val))) 144 | (* (+ (v3! 7.0) (* (- val³ (v3! 7.0)) val)) val³))) 145 | 146 | (defun-g quintic-fast ((min :float) (max :float) (x :vec4)) 147 | (let* ((max (v4! max)) 148 | (min (v4! min)) 149 | (val (clamp (/ (- x min) (- max min)) 0f0 1f0)) 150 | (val³ (* val val val))) 151 | (* (+ (v4! 7.0) (* (- val³ (v4! 7.0)) val)) val³))) 152 | 153 | ;;------------------------------------------------------------ 154 | ;; Quintic Hermite Interpolation 155 | ;; http://www.rose-hulman.edu/~finn/CCLI/Notes/day09.pdf 156 | ;; 157 | ;; NOTE: maximum value of a hermitequintic interpolation with zero acceleration 158 | ;; at the endpoints would be... 159 | ;; f(x=0.5) = MAXPOS + MAXVELOCITY * ( ( x - 6x^3 + 8x^4 - 3x^5 ) - ( -4x^3 + 7x^4 -3x^5 ) ) = MAXPOS + MAXVELOCITY * 0.3125 160 | ;; 161 | ;; variable naming conventions: 162 | ;; val = value ( position ) 163 | ;; grad = gradient ( velocity ) 164 | ;; x = 0.0->1.0 ( time ) 165 | ;; i = interpolation = a value to be interpolated 166 | ;; e = evaluation = a value to be used to calculate the interpolation 167 | ;; 0 = start 168 | ;; 1 = end 169 | 170 | (defun-g quintic-hermite 171 | ((x :float) (ival0 :float) (ival1 :float) (egrad0 :float) (egrad1 :float)) 172 | (let* ((c0 (v3! (- 15.0) 8.0 7.0)) 173 | (c1 (v3! 6.0 (- 3.0) (- 3.0))) 174 | (c2 (v3! 10.0 (- 6.0) (- 4.0))) 175 | (h123 (* (+ (* (+ c0 (* c1 x)) x) c2) (* x x x)))) 176 | (+ ival0 177 | (dot (v3! (- ival1 ival0) egrad0 egrad1) 178 | (+ (s~ h123 :xyz) (v3! 0.0 x 0.0)))))) 179 | 180 | (defun-g quintic-hermite 181 | ((x :float) (ival0 :vec4) (ival1 :vec4) (egrad0 :vec4) (egrad1 :vec4)) 182 | (let* ((c0 (v3! (- 15.0) 8.0 7.0)) 183 | (c1 (v3! 6.0 (- 3.0) (- 3.0))) 184 | (c2 (v3! 10.0 (- 6.0) (- 4.0))) 185 | (h123 (* (+ (* (+ c0 (* c1 x)) x) c2) (* x x x)))) 186 | (+ ival0 187 | (+ (* (- ival1 ival0) (s~ h123 :xxxx)) 188 | (+ (* egrad0 (v4! (+ (y h123) x))) (* egrad1 (s~ h123 :zzzz))))))) 189 | 190 | (defun-g quintic-hermite ((x :float) 191 | (igrad0 :vec2) (igrad1 :vec2) 192 | (egrad0 :vec2) (egrad1 :vec2)) 193 | (let* ((c0 (v3! (- 15.0) 8.0 7.0)) 194 | (c1 (v3! 6.0 (- 3.0) (- 3.0))) 195 | (c2 (v3! 10.0 (- 6.0) (- 4.0))) 196 | (h123 (* (+ (* (+ c0 (* c1 x)) x) c2) (* x x x)))) 197 | (+ (* (v! egrad1 igrad0) 198 | (v! (s~ h123 :zz) 1.0 1.0)) 199 | (* (v! egrad0 (s~ h123 :xx)) 200 | (v! (v2! (+ (y h123) x)) (- igrad1 igrad0)))))) 201 | 202 | (defun-g quintic-hermite ((x :float) 203 | (ival0 :vec4) (ival1 :vec4) 204 | (igrad-x0 :vec4) (igrad-x1 :vec4) 205 | (igrad-y0 :vec4) (igrad-y1 :vec4) 206 | (egrad0 :vec4) (egrad1 :vec4)) 207 | (let* ((c0 (v3! (- 15.0) 8.0 7.0)) 208 | (c1 (v3! 6.0 (- 3.0) (- 3.0))) 209 | (c2 (v3! 10.0 (- 6.0) (- 4.0))) 210 | (h123 (* (+ (* (+ c0 (* c1 x)) x) c2) (* x x x))) 211 | (out-ival 212 | (+ ival0 213 | (+ (* (- ival1 ival0) (s~ h123 :xxxx)) 214 | (+ (* egrad0 (v4! (+ (y h123) x))) 215 | (* egrad1 (s~ h123 :zzzz)))))) 216 | (out-igrad-x (+ igrad-x0 (* (- igrad-x1 igrad-x0) (s~ h123 :xxxx)))) 217 | (out-igrad-y 218 | (+ igrad-y0 (* (- igrad-y1 igrad-y0) (s~ h123 :xxxx))))) 219 | (values out-ival out-igrad-x out-igrad-y))) 220 | 221 | (defun-g quintic-hermite ((x :float) 222 | (igrad-x0 :vec4) (igrad-x1 :vec4) (igrad-y0 :vec4) 223 | (igrad-y1 :vec4) (egrad0 :vec4) (egrad1 :vec4)) 224 | (let* ((c0 (v3! (- 15.0) 8.0 7.0)) 225 | (c1 (v3! 6.0 (- 3.0) (- 3.0))) 226 | (c2 (v3! 10.0 (- 6.0) (- 4.0))) 227 | (h123 (* (+ (* (+ c0 (* c1 x)) x) c2) (* x x x))) 228 | (out-ival 229 | (+ (* egrad0 (v4! (+ (y h123) x))) (* egrad1 (s~ h123 :zzzz)))) 230 | (out-igrad-x (+ igrad-x0 (* (- igrad-x1 igrad-x0) (s~ h123 :xxxx)))) 231 | (out-igrad-y 232 | (+ igrad-y0 (* (- igrad-y1 igrad-y0) (s~ h123 :xxxx))))) 233 | (values out-ival out-igrad-x out-igrad-y))) 234 | 235 | (defun-g quintic-hermite-deriv ((x :float) 236 | (ival0 :float) (ival1 :float) 237 | (egrad0 :float) (egrad1 :float)) 238 | (let* ((c0 (v3! 30.0 (- 15.0) (- 15.0))) 239 | (c1 (v3! (- 60.0) 32.0 28.0)) 240 | (c2 (v3! 30.0 (- 18.0) (- 12.0))) 241 | (h123 (* (+ (* (+ c1 (* c0 x)) x) c2) (* x x)))) 242 | (dot (v3! (- ival1 ival0) egrad0 egrad1) 243 | (+ (s~ h123 :xyz) (v3! 0.0 1.0 0.0))))) 244 | 245 | ;;------------------------------------------------------------ 246 | -------------------------------------------------------------------------------- /hashing/docs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.hashing) 2 | 3 | (docs:define-docs 4 | (defun blum-blum-shub-hash 5 | " 6 | -- Signatures -- 7 | 8 | ((grid-cell :vec2)) --> :vec4 9 | 10 | ((grid-cell :vec3)) --> (values :vec4 :vec4) 11 | 12 | grid-cell is assumed to be an integer coordinate 13 | 14 | -- Wikipedia Explanation -- 15 | 16 | Blum Blum Shub (BBS) is a pseudorandom number generator proposed in 1986 by 17 | Lenore Blum, Manuel Blum and Michael Shub. It takes the form: 18 | 19 | x_n_plus_1 = mod( x_n^2, M ) 20 | 21 | where M=pq is the product of two large primes p and q 22 | 23 | -- GPU Version -- 24 | 25 | This is an implementation of the hashing function described in Marc Olano’s 26 | MNoise Paper. It calculates pseudo-random values in the 0.0->1.0 range. 27 | 28 | It includes an extra permutation pass to reduce the worst of the artifacts 29 | from the classic version 30 | 31 | It can run on 16bit and 24bit floating point hardware. 32 | 33 | Generates a random number for each of the cell corners, each are returned as 34 | one element of the resulting vectors. 35 | 36 | -- Credit -- 37 | 38 | Marc Olano - http://www.cs.umbc.edu/~olano/papers/mNoise.pdf 39 | 40 | Brain Sharpe - For his phenominal explanations 41 | https://briansharpe.wordpress.com/2011/10/01/gpu-texture-free-noise/ 42 | 43 | ") 44 | 45 | (defun blum-blum-shub-hash-low-quality 46 | " 47 | -- Signatures -- 48 | 49 | ((grid-cell :vec2)) --> :vec4 50 | 51 | ((grid-cell :vec3)) --> (values :vec4 :vec4) 52 | 53 | grid-cell is assumed to be an integer coordinate 54 | 55 | -- Wikipedia Explanation -- 56 | 57 | Blum Blum Shub (BBS) is a pseudorandom number generator proposed in 1986 by 58 | Lenore Blum, Manuel Blum and Michael Shub. It takes the form: 59 | 60 | x_n_plus_1 = mod( x_n^2, M ) 61 | 62 | where M=pq is the product of two large primes p and q 63 | 64 | -- GPU Version -- 65 | 66 | This is an implementation of the hashing function described in Marc Olano’s 67 | MNoise Paper. It calculates pseudo-random values in the 0.0->1.0 range. 68 | 69 | This version lacks the extra permutation pass that is in #'blum-blum-shub-hash 70 | so suffers from the artifacts present in the version from the paper. 71 | 72 | It can run on 16bit and 24bit floating point hardware. 73 | 74 | Generates a random number for each of the cell corners, each are returned as 75 | one element of the resulting vectors. 76 | 77 | -- Credit -- 78 | 79 | Marc Olano - http://www.cs.umbc.edu/~olano/papers/mNoise.pdf 80 | 81 | Brain Sharpe - For his phenominal explanations 82 | https://briansharpe.wordpress.com/2011/10/01/gpu-texture-free-noise/ 83 | 84 | ") 85 | 86 | (defun sgim-qpp-hash 87 | " 88 | -- Signatures -- 89 | 90 | ((grid-cell :vec2)) --> :vec4 91 | 92 | ((grid-cell :vec3)) --> (values :vec4 :vec4) 93 | 94 | grid-cell is assumed to be an integer coordinate 95 | 96 | -- Purpose -- 97 | 98 | This is an implementation of a quadratic permutation polynomial hash function. 99 | It calculates pseudo-random values in the 0.0->1.0 range. 100 | 101 | Generates a random number for each of the cell corners. Each are returned as 102 | one element of the resulting vectors. 103 | 104 | -- Credit -- 105 | 106 | Brain Sharpe - The implementation is taken from his excellent article here: 107 | https://briansharpe.wordpress.com/2011/10/01/gpu-texture-free-noise/ 108 | 109 | Stefan Gustavson and Ian McEwan - For the permutation polynomial based gpu 110 | hashing idea 111 | ") 112 | 113 | (defun sgim-qpp-hash-2-per-corner 114 | " 115 | -- Signatures -- 116 | 117 | ((grid-cell :vec2)) --> (values :vec4 :vec4) 118 | 119 | grid-cell is assumed to be an integer coordinate 120 | 121 | -- Purpose -- 122 | 123 | This is an implementation of a quadratic permutation polynomial hash function. 124 | It calculates pseudo-random values in the 0.0->1.0 range. 125 | 126 | Generates 2 random numbers for each of the cell corners. Each are returned as 127 | one element of the resulting vectors. 128 | 129 | -- Credit -- 130 | 131 | Brain Sharpe - The implementation is taken from his excellent article here: 132 | https://briansharpe.wordpress.com/2011/10/01/gpu-texture-free-noise/ 133 | 134 | Stefan Gustavson and Ian McEwan - For the permutation polynomial based gpu 135 | hashing idea 136 | ") 137 | 138 | (defun sgim-qpp-hash-3-per-corner 139 | " 140 | -- Signatures -- 141 | 142 | ((grid-cell :vec3)) --> (values :vec4 :vec4 :vec4 :vec4 :vec4 :vec4) 143 | 144 | ((grid-cell :vec3) (v1-mask :vec3) (v2-mask :vec3)) 145 | --> 146 | (values :vec4 :vec4 :vec4) 147 | 148 | grid-cell is assumed to be an integer coordinate 149 | 150 | -- Purpose -- 151 | 152 | This is an implementation of a quadratic permutation polynomial hash function. 153 | It calculates pseudo-random values in the 0.0->1.0 range. 154 | 155 | This comes in 2 flavors, regular and masked. 156 | 157 | The regular form generates 3 random numbers for each of the cell corners. 158 | Each are returned as one element of the resulting vectors. 159 | 160 | The masked variant generates 3 random numbers for the 4 3D cell corners. 2 of 161 | the corners are pre-set (v0=0,0,0 v3=1,1,1) but the other two are user 162 | definable. 163 | 164 | -- Credit -- 165 | 166 | Brain Sharpe - The implementation is taken from his excellent article here: 167 | https://briansharpe.wordpress.com/2011/10/01/gpu-texture-free-noise/ 168 | 169 | Stefan Gustavson and Ian McEwan - For the permutation polynomial based gpu 170 | hashing idea 171 | ") 172 | 173 | (defun bs-fast32-hash 174 | " 175 | -- Signatures -- 176 | 177 | ((grid-cell :vec2)) --> :vec4 178 | 179 | ((grid-cell :vec3)) --> (values :vec4 :vec4) 180 | 181 | ((grid-cell :vec3) (v1-mask :vec3) (v2-mask :vec3)) --> :vec4 182 | 183 | grid-cell is assumed to be an integer coordinate 184 | 185 | -- Description -- 186 | 187 | Brian Sharpe's fast 32bit hashing function. It calculates pseudo-random 188 | values in the 0.0->1.0 range. 189 | 190 | This comes in 2 flavors, regular and masked. 191 | 192 | The regular forms generates 1 random number for each of the cell corners. 193 | Each are returned as one element of the resulting vector/s. 194 | 195 | The masked variant generates 1 random number for the 4 3D cell corners. 2 of 196 | the corners are pre-set (v0=0,0,0 v3=1,1,1) but the other two are user 197 | definable. 198 | 199 | Requires 32bit support. 200 | 201 | -- Credit -- 202 | 203 | Brain Sharpe - The implementation is taken from his excellent article here: 204 | https://briansharpe.wordpress.com/2011/11/15/a-fast-and-simple-32bit-floating-point-hash-function/ 205 | ") 206 | 207 | (defun bs-fast32-hash-2-per-corner 208 | " 209 | -- Signatures -- 210 | 211 | ((grid-cell :vec2)) --> (values :vec4 :vec4) 212 | 213 | grid-cell is assumed to be an integer coordinate 214 | 215 | -- Description -- 216 | 217 | Brian Sharpe's fast 32bit hashing function. It calculates pseudo-random 218 | values in the 0.0->1.0 range. 219 | 220 | This generates 2 randoms number for each of the cell corners. Each are returned 221 | as one element of the 2 resulting vectors. 222 | 223 | Requires 32bit support. 224 | 225 | -- Credit -- 226 | 227 | Brain Sharpe - The implementation is taken from his excellent article here: 228 | https://briansharpe.wordpress.com/2011/11/15/a-fast-and-simple-32bit-floating-point-hash-function/ 229 | ") 230 | 231 | (defun bs-fast32-hash-3-per-corner 232 | " 233 | -- Signatures -- 234 | 235 | ((grid-cell :vec2)) --> (values :vec4 :vec4 :vec4) 236 | 237 | ((grid-cell :vec3)) --> (values :vec4 :vec4 :vec4 :vec4 :vec4 :vec4) 238 | 239 | ((grid-cell :vec3) (v1-mask :vec3) (v2-mask :vec3)) 240 | --> 241 | (values :vec4 :vec4 :vec4) 242 | 243 | grid-cell is assumed to be an integer coordinate 244 | 245 | -- Description -- 246 | 247 | Brian Sharpe's fast 32bit hashing function. It calculates pseudo-random 248 | values in the 0.0->1.0 range. 249 | 250 | This comes in 2 flavors, regular and masked. 251 | 252 | The regular forms generates 3 random numbers for each of the cell corners. 253 | Each are returned as one element of the resulting vector/s. 254 | 255 | The masked variant generates 3 random numbers for the 4 3D cell corners. 2 of 256 | the corners are pre-set (v0=0,0,0 v3=1,1,1) but the other two are user 257 | definable. 258 | 259 | Requires 32bit support. 260 | 261 | -- Credit -- 262 | 263 | Brain Sharpe - The implementation is taken from his excellent article here: 264 | https://briansharpe.wordpress.com/2011/11/15/a-fast-and-simple-32bit-floating-point-hash-function/ 265 | ") 266 | 267 | (defun bs-quick-hash 268 | " 269 | -- Signatures -- 270 | 271 | ((grid-cell :vec2)) --> :vec4 272 | 273 | ((grid-cell :vec3)) --> (values :vec4 :vec4) 274 | 275 | ((grid-cell :vec3) (v1-mask :vec3) (v2-mask :vec3)) --> :vec4 276 | 277 | grid-cell is assumed to be an integer coordinate 278 | 279 | -- Description -- 280 | 281 | Brian Sharpe's FastHash32_2 hashing function. It calculates pseudo-random 282 | values in the 0.0->1.0 range. 283 | 284 | An alternative to bs-fast32-hash that is: 285 | - slightly slower 286 | - can have a larger domain 287 | - allows for a 4D implementation 288 | 289 | This generates 1 random number for each of the cell corners. Each are returned 290 | as one element of the resulting vector/s. 291 | 292 | Requires 32bit support. 293 | 294 | -- Credit -- 295 | 296 | Brain Sharpe - The implementation is taken from his excellent article here: 297 | https://briansharpe.wordpress.com/2011/11/15/a-fast-and-simple-32bit-floating-point-hash-function/ 298 | ") 299 | 300 | (defun bs-quick-hash-4-per-corner 301 | " 302 | -- Signatures -- 303 | 304 | ((grid-cell :vec2)) --> :vec4 305 | 306 | ((grid-cell :vec3)) --> (values :vec4 :vec4) 307 | 308 | ((grid-cell :vec3) (v1-mask :vec3) (v2-mask :vec3)) --> :vec4 309 | 310 | grid-cell is assumed to be an integer coordinate 311 | 312 | -- Description -- 313 | 314 | Brian Sharpe's FastHash32_2 hashing function. It calculates pseudo-random 315 | values in the 0.0->1.0 range. 316 | 317 | An alternative to bs-fast32-hash that is: 318 | - slightly slower 319 | - can have a larger domain 320 | - allows for a 4D implementation 321 | 322 | This generates 4 random numbers for each of the cell corners. Each are returned 323 | as one element of the resulting vector/s. 324 | 325 | Requires 32bit support. 326 | 327 | -- Credit -- 328 | 329 | Brain Sharpe - The implementation is taken from his excellent article here: 330 | https://briansharpe.wordpress.com/2011/11/15/a-fast-and-simple-32bit-floating-point-hash-function/ 331 | ")) 332 | -------------------------------------------------------------------------------- /sdf/2d/sdf.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.sdf.2d) 2 | 3 | ;;============================================================ 4 | ;; Big love to: 5 | ;; - Maarten: for the fantastic 2D sdf function playground 6 | ;;; which is the principle basis for this code: 7 | ;; https://www.shadertoy.com/view/4dfXDn 8 | ;; - iq: for many example sdf functions on shadertoy 9 | ;; - iq: for many example sdf functions on shadertoy 10 | ;;============================================================ 11 | 12 | ;;------------------------------------------------------------ 13 | ;; Combine distance field functions 14 | 15 | (defun-g merge-smooth ((d1 :float) (d2 :float) (k :float)) 16 | (let ((h (clamp (+ 0.5 17 | (* 0.5 18 | (/ (- d2 d1) 19 | k))) 20 | 0.0 21 | 1.0))) 22 | (- (mix d2 d1 h) 23 | (* k h (- 1.0 h))))) 24 | 25 | (defun-g merge-simple ((d1 :float) (d2 :float)) 26 | (min d1 d2)) 27 | 28 | (defun-g merge-exclude ((d1 :float) (d2 :float)) 29 | (min (max (- d1) d2) 30 | (max (- d2) d1))) 31 | 32 | (defun-g subtract ((d1 :float) (d2 :float)) 33 | (max (- d1) d2)) 34 | 35 | (defun-g intersect ((d1 :float) (d2 :float)) 36 | (max d1 d2)) 37 | 38 | ;;------------------------------------------------------------ 39 | ;; Masks for drawing 40 | 41 | (defun-g mask-fill ((dist :float)) 42 | (clamp (- dist) 0.0 1.0)) 43 | 44 | (defun-g mask-border-inner ((dist :float) (width :float)) 45 | (let* ((alpha1 (clamp (+ dist width) 0.0 1.0)) 46 | (alpha2 (clamp dist 0.0 1.0))) 47 | (- alpha1 alpha2))) 48 | 49 | (defun-g mask-border-outer ((dist :float) (width :float)) 50 | (let* ((alpha1 (clamp dist 0.0 1.0)) 51 | (alpha2 (clamp (- dist width) 0.0 1.0))) 52 | (- alpha1 alpha2))) 53 | 54 | ;;------------------------------------------------------------ 55 | ;; Light & Shadow 56 | 57 | (defun-g cast-shadow ((fn (function (:vec2) :float)) 58 | (p :vec2) 59 | (light-position :vec2) 60 | (source-radius :float)) 61 | (let* ((dir (normalize (- light-position p))) 62 | ;; distance to light 63 | (dl (length (- p light-position))) 64 | ;; fraction of light visible, starts at one radius 65 | ;; (second half added in the end) 66 | (lf (* source-radius dl)) 67 | ;; distance traveled 68 | (dt 0.01)) 69 | (dotimes (i 64) 70 | (let (;; distance to scene at current position 71 | (sd (funcall fn (+ p (* dir dt))))) 72 | ;; early out when this ray is guaranteed to be full shadow 73 | (when (< sd (- source-radius)) 74 | (return 0.0)) 75 | ;; width of cone-overlap at light 76 | ;; 0 in center, so 50% overlap: add one radius outside of loop to 77 | ;; get total coverage. 78 | ;; should be '(sd / dt) * dl', but '*dl' outside of loop 79 | (setf lf (min lf (/ sd dt))) 80 | ;; move ahead 81 | (incf dt (max 1.0 (abs sd))) 82 | (when (> dt dl) 83 | (break)))) 84 | ;; multiply by dl to get the real projected overlap (moved out of loop) 85 | ;; add one radius, before between -radius and + radius 86 | ;; normalize to 1 ( / 2*radius) 87 | (setf lf (clamp (/ (+ (* lf dl) source-radius) (* 2.0 source-radius)) 88 | 0.0 89 | 1.0)) 90 | (setf lf (smoothstep 0.0 1.0 lf)) 91 | lf)) 92 | 93 | ;; Not exposing the shaped versions yet, I want to work out a nicer term 94 | ;; for the shaping function 95 | 96 | (defun-g shaped-light-with-source ((fn (function (:vec2) :float)) 97 | (light-fn (function (:vec2) :float)) 98 | (p :vec2) 99 | (light-position :vec2) 100 | (light-color :vec4) 101 | (light-range :float) 102 | (source-radius :float)) 103 | (let* (;; distance to light 104 | (ld (funcall light-fn (- p light-position)))) 105 | (if (> ld light-range) 106 | (vec4 0.0) 107 | (let* ((shad (cast-shadow fn p light-position source-radius)) 108 | (fall (/ (- light-range ld) light-range)) 109 | (fall (* fall fall)) 110 | (source (mask-fill (- ld source-radius)))) 111 | (* (+ (* shad fall) source) 112 | light-color))))) 113 | 114 | (defun-g shaped-light ((fn (function (:vec2) :float)) 115 | (light-fn (function (:vec2) :float)) 116 | (p :vec2) 117 | (light-position :vec2) 118 | (light-color :vec4) 119 | (light-range :float) 120 | (source-radius :float)) 121 | (let* (;; distance to light 122 | (ld (funcall light-fn (- p light-position)))) 123 | (if (> ld light-range) 124 | (vec4 0.0) 125 | (let* ((shad (cast-shadow fn p light-position source-radius)) 126 | (fall (/ (- light-range ld) light-range)) 127 | (fall (* fall fall))) 128 | (* shad fall light-color))))) 129 | 130 | (defun-g point-light-with-source ((fn (function (:vec2) :float)) 131 | (p :vec2) 132 | (light-position :vec2) 133 | (light-color :vec4) 134 | (light-range :float) 135 | (source-radius :float)) 136 | (shaped-light-with-source fn 137 | #'(length :vec2) 138 | p 139 | light-position 140 | light-color 141 | light-range 142 | source-radius)) 143 | 144 | (defun-g point-light ((fn (function (:vec2) :float)) 145 | (p :vec2) 146 | (light-position :vec2) 147 | (light-color :vec4) 148 | (light-range :float) 149 | (source-radius :float)) 150 | (shaped-light fn 151 | #'(length :vec2) 152 | p 153 | light-position 154 | light-color 155 | light-range 156 | source-radius)) 157 | 158 | 159 | ;;------------------------------------------------------------ 160 | ;; Distance Field Functions 161 | 162 | (defun-g rhombus ((p :vec2) 163 | (size :vec2) 164 | (corner-radius :float)) 165 | (flet ((ndot ((a :vec2) (b :vec2)) 166 | (- (* (x a) (x b)) 167 | (* (y a) (y b))))) 168 | (let* ((q (abs p)) 169 | (h (clamp (/ (+ (* -2.0 (ndot q size)) 170 | (ndot size size)) 171 | (dot size size)) 172 | -1.0 173 | 1.0)) 174 | (d (length (- q (* 0.5 size (vec2 (- 1.0 h) (+ 1.0 h)))))) 175 | (d (* d (sign (- (+ (* (x q) (y size)) 176 | (* (y q) (x size))) 177 | (* (x size) (y size))))))) 178 | (- d corner-radius)))) 179 | 180 | (defun-g circle ((p :vec2) (radius :float)) 181 | (- (length p) radius)) 182 | 183 | (defun-g triangle ((p :vec2) (radius :float)) 184 | (- (max (+ (* (x (abs p)) 0.866025) 185 | (* (y p) 0.5)) 186 | (- (y p))) 187 | (* 0.5 radius))) 188 | 189 | (defun-g triangle ((p :vec2) 190 | (corner0 :vec2) 191 | (corner1 :vec2) 192 | (corner2 :vec2)) 193 | (let* ((e0 (- corner1 corner0)) 194 | (e1 (- corner2 corner1)) 195 | (e2 (- corner0 corner2)) 196 | (v0 (- p corner0)) 197 | (v1 (- p corner1)) 198 | (v2 (- p corner2)) 199 | (pq0 (- v0 (* e0 (clamp (/ (dot v0 e0) (dot e0 e0)) 200 | 0.0 201 | 1.0)))) 202 | (pq1 (- v1 (* e1 (clamp (/ (dot v1 e1) (dot e1 e1)) 203 | 0.0 204 | 1.0)))) 205 | (pq2 (- v2 (* e2 (clamp (/ (dot v2 e2) (dot e2 e2)) 206 | 0.0 207 | 1.0)))) 208 | (s (sign (- (* (x e0) (y e2)) 209 | (* (y e0) (x e2))))) 210 | (d (min (min (v2! (dot pq0 pq0) 211 | (* s (- (* (x v0) (y e0)) 212 | (* (y v0) (x e0))))) 213 | (v2! (dot pq1 pq1) 214 | (* s (- (* (x v1) (y e1)) 215 | (* (y v1) (x e1)))))) 216 | (v2! (dot pq2 pq2) (* s (- (* (x v2) (y e2)) 217 | (* (y v2) (x e2)))))))) 218 | (* (- (sqrt (x d))) 219 | (sign (y d))))) 220 | 221 | (defun-g triangle ((p :vec2) (width :float) (height :float)) 222 | (let ((n (normalize (vec2 height (/ width 2.0))))) 223 | (max (- (+ (* (x (abs p)) (x n)) 224 | (* (y p) (y n))) 225 | (* height (y n))) 226 | (- (y p))))) 227 | 228 | (defun-g pie ((p :vec2) (angle :float)) 229 | (let* ((angle (/ angle 2.0)) 230 | (n (vec2 (cos angle) (sin angle)))) 231 | (+ (* (x (abs p)) (x n)) 232 | (* (y p) (y n))))) 233 | 234 | (defun-g semicircle ((p :vec2) 235 | (radius :float) 236 | (angle :float) 237 | (line-width :float)) 238 | (let* ((line-width (/ line-width 2f0)) 239 | (radius (- radius line-width))) 240 | (subtract (pie p angle) 241 | (- (abs (circle p radius)) line-width)))) 242 | 243 | (defun-g rectangle ((p :vec2) (size :vec2) (corner-radius :float)) 244 | (let* ((size (- size (vec2 corner-radius))) 245 | (d (- (abs p) size))) 246 | (- (+ (min (max (x d) (y d)) 0.0) 247 | (length (max d 0.0))) 248 | corner-radius))) 249 | 250 | (defun-g rectangle ((p :vec2) (size :vec2)) 251 | (let* ((d (- (abs p) size))) 252 | (+ (min (max (x d) (y d)) 0.0) 253 | (length (max d 0.0))))) 254 | 255 | (defun-g fast-rect ((p :vec2) (size :vec2)) 256 | (vmax (- (abs p) size))) 257 | 258 | (defun-g hexagon ((p :vec2) (h :float)) 259 | (let* ((q (abs p))) 260 | (- (max (+ (* (x q) 0.866025) 261 | (* (y q) 0.5)) 262 | (y q)) 263 | h))) 264 | 265 | (defun-g line ((p :vec2) (start :vec2) (end :vec2) (line-width :float)) 266 | (let* ((dir (- start end)) 267 | (length (length dir)) 268 | (dir (/ dir length)) 269 | (proj (* (max 0.0 (min length (dot (- start p) dir))) 270 | dir))) 271 | (- (length (- start p proj)) 272 | (/ line-width 2.0)))) 273 | 274 | ;;------------------------------------------------------------ 275 | 276 | (defun-g rotate-ccw ((p :vec2) (angle :float)) 277 | (let ((m (mat2 (cos angle) (sin angle) 278 | (- (sin angle)) (cos angle)))) 279 | (* m p))) 280 | 281 | (defun-g translate ((p :vec2) (offset :vec2)) 282 | (- p offset)) 283 | 284 | ;;------------------------------------------------------------ 285 | -------------------------------------------------------------------------------- /textures/draw-texture.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh) 2 | 3 | ;;------------------------------------------------------------ 4 | 5 | (defgeneric draw-tex (tex &key scale flip-uvs-vertically)) 6 | (defgeneric draw-tex-tl (sampler &key flip-uvs-vertically)) 7 | (defgeneric draw-tex-bl (sampler &key flip-uvs-vertically)) 8 | (defgeneric draw-tex-tr (sampler &key flip-uvs-vertically)) 9 | (defgeneric draw-tex-br (sampler &key flip-uvs-vertically)) 10 | (defgeneric draw-tex-at (sampler &key pos centered flip-uvs-vertically)) 11 | 12 | ;;------------------------------------------------------------ 13 | 14 | (defun-g draw-texture-vert ((vert g-pt) &uniform (transform :mat4) 15 | (uv-y-mult :float)) 16 | (values (* transform (v! (pos vert) 1s0)) 17 | (* (tex vert) (v! 1 uv-y-mult)))) 18 | 19 | (defun-g draw-texture-frag ((tc :vec2) &uniform (tex :sampler-2d) 20 | (color-scale :vec4)) 21 | (* (texture tex tc) color-scale)) 22 | 23 | (defpipeline-g draw-texture-pipeline () 24 | #'(draw-texture-vert g-pt) #'(draw-texture-frag :vec2)) 25 | 26 | ;;------------------------------------------------------------ 27 | 28 | (defun-g draw-cube-face-vert ((vert g-pt) &uniform (transform :mat4) 29 | (uv-mult :vec2)) 30 | (values (* transform (v! (pos vert) 1s0)) 31 | (* (s~ (pos vert) :xy) uv-mult 2))) 32 | 33 | (defun-g draw-cube-face-frag ((tc :vec2) &uniform (tex :sampler-cube) 34 | (mat :mat3) (color-scale :vec4)) 35 | (* (texture tex (* mat (v! tc -1))) 36 | color-scale)) 37 | 38 | (defpipeline-g draw-cube-face-pipeline () 39 | #'(draw-cube-face-vert g-pt) #'(draw-cube-face-frag :vec2)) 40 | 41 | ;;------------------------------------------------------------ 42 | 43 | (defun %draw-cube-face (sampler pos-vec2 rotation scale color-scale) 44 | (let* ((tex (sampler-texture sampler)) 45 | (tex-res (resolution tex)) 46 | (win-res (resolution (current-viewport))) 47 | (rect-res (rotated-rect-size (v2:* tex-res (v! 3 4)) rotation)) 48 | (fit-scale (* (get-fit-to-rect-scale win-res rect-res) 2)) 49 | (quad (nineveh.internals:get-gpu-quad))) 50 | (labels ((calc-trans (pos) 51 | (m4:* 52 | (m4:translation (v! pos-vec2 0)) 53 | (m4:scale (v3:*s (v! (/ 1 (x win-res)) 54 | (/ 1 (y win-res)) 55 | 0) 56 | (* scale fit-scale))) 57 | (m4:rotation-z rotation) 58 | (m4:scale (v! tex-res 0)) 59 | (m4:translation pos)))) 60 | (map-g #'draw-cube-face-pipeline quad 61 | :mat (m3:rotation-x (radians 90)) 62 | :tex sampler 63 | :uv-mult (v! 1 -1) 64 | :transform (calc-trans (v! 0 1.5 0)) 65 | :color-scale color-scale) 66 | (map-g #'draw-cube-face-pipeline quad 67 | :mat (m3:rotation-y (radians 90)) 68 | :tex sampler 69 | :uv-mult (v! -1 1) 70 | :transform (calc-trans (v! -1 0.5 0)) 71 | :color-scale color-scale) 72 | (map-g #'draw-cube-face-pipeline quad 73 | :mat (m3:rotation-y (radians -90)) 74 | :tex sampler 75 | :uv-mult (v! -1 1) 76 | :transform (calc-trans (v! 1 0.5 0)) 77 | :color-scale color-scale) 78 | (map-g #'draw-cube-face-pipeline quad 79 | :mat (m3:rotation-x (radians 180)) 80 | :tex sampler 81 | :uv-mult (v! 1 -1) 82 | :transform (calc-trans (v! 0 0.5 0)) 83 | :color-scale color-scale) 84 | (map-g #'draw-cube-face-pipeline quad 85 | :mat (m3:rotation-x (radians -90)) 86 | :tex sampler 87 | :uv-mult (v! 1 -1) 88 | :transform (calc-trans (v! 0 -0.5 0)) 89 | :color-scale color-scale) 90 | (map-g #'draw-cube-face-pipeline quad 91 | :mat (m3:rotation-x (radians 0)) 92 | :tex sampler 93 | :uv-mult (v! 1 -1) 94 | :transform (calc-trans (v! 0 -1.5 0)) 95 | :color-scale color-scale)))) 96 | 97 | ;;------------------------------------------------------------ 98 | 99 | (defun %draw-sampler (sampler pos-vec2 rotation scale flip-uvs-vertically 100 | color-scale) 101 | (let* ((tex (sampler-texture sampler)) 102 | (tex-res (resolution tex)) 103 | (win-res (resolution (current-viewport))) 104 | (rect-res (rotated-rect-size tex-res rotation)) 105 | (fit-scale (* (get-fit-to-rect-scale win-res rect-res) 2)) 106 | (transform 107 | (m4:* 108 | (m4:translation (v! pos-vec2 0)) 109 | (m4:scale (v3:*s (v! (/ 1 (x win-res)) 110 | (/ 1 (y win-res)) 111 | 0) 112 | (float scale))) 113 | (m4:rotation-z rotation) 114 | (m4:scale (v3:*s (v! tex-res 0) fit-scale))))) 115 | (map-g #'draw-texture-pipeline (nineveh.internals:get-gpu-quad) 116 | :tex sampler 117 | :transform transform 118 | :uv-y-mult (if flip-uvs-vertically -1s0 1s0) ;; this is a bug as it samples outside of texture 119 | :color-scale color-scale))) 120 | 121 | (defun rotated-rect-size (size-v2 φ) 122 | ;; returns width & height 123 | (let ((w (x size-v2)) 124 | (h (y size-v2))) 125 | (v! (+ (* w (abs (cos φ))) 126 | (* h (abs (sin φ)))) 127 | (+ (* w (abs (sin φ))) 128 | (* h (abs (cos φ))))))) 129 | 130 | (defun get-fit-to-rect-scale (target-v2 to-fit-v2) 131 | (min (/ (x target-v2) (x to-fit-v2)) 132 | (/ (y target-v2) (y to-fit-v2)))) 133 | 134 | ;;------------------------------------------------------------ 135 | 136 | (defmethod draw-tex ((tex texture) 137 | &key (scale 0.9) (flip-uvs-vertically nil) 138 | (color-scale (v! 1 1 1 1))) 139 | (with-temp-sampler (s tex) 140 | (draw-tex s :scale scale 141 | :flip-uvs-vertically flip-uvs-vertically 142 | :color-scale color-scale))) 143 | 144 | (defmethod draw-tex ((sampler sampler) 145 | &key (scale 0.9) (flip-uvs-vertically nil) 146 | (color-scale (v! 1 1 1 1))) 147 | (cepl-utils:with-setf (depth-test-function (cepl-context)) nil 148 | (if (eq (sampler-type sampler) :sampler-cube) 149 | (%draw-cube-face sampler (v! -0 0) 1.5707 scale color-scale) 150 | (%draw-sampler sampler (v! 0 0) 0s0 scale flip-uvs-vertically color-scale)))) 151 | 152 | ;;------------------------------------------------------------ 153 | 154 | (defun draw-tex-top-left (sampler/tex 155 | &key (flip-uvs-vertically nil) 156 | (color-scale (v! 1 1 1 1))) 157 | (draw-tex-tl sampler/tex 158 | :flip-uvs-vertically flip-uvs-vertically 159 | :color-scale color-scale)) 160 | 161 | (defmethod draw-tex-tl ((sampler sampler) 162 | &key (flip-uvs-vertically nil) 163 | (color-scale (v! 1 1 1 1))) 164 | (if (eq (sampler-type sampler) :sampler-cube) 165 | (%draw-cube-face sampler (v! -0.5 0.5) 1.5707 0.5 color-scale) 166 | (%draw-sampler sampler (v! -0.5 0.5) 0s0 0.5 flip-uvs-vertically color-scale))) 167 | 168 | ;;------------------------------------------------------------ 169 | 170 | (defun draw-tex-bottom-left (sampler/tex 171 | &key (flip-uvs-vertically nil) 172 | (color-scale (v! 1 1 1 1))) 173 | (draw-tex-bl sampler/tex 174 | :flip-uvs-vertically flip-uvs-vertically 175 | :color-scale color-scale)) 176 | 177 | (defmethod draw-tex-bl ((sampler sampler) 178 | &key (flip-uvs-vertically nil) 179 | (color-scale (v! 1 1 1 1))) 180 | (if (eq (sampler-type sampler) :sampler-cube) 181 | (%draw-cube-face sampler (v! -0.5 -0.5) 1.5707 0.5 color-scale) 182 | (%draw-sampler sampler (v! -0.5 -0.5) 0s0 0.5 flip-uvs-vertically color-scale))) 183 | 184 | ;;------------------------------------------------------------ 185 | 186 | (defun draw-tex-top-right (sampler/tex 187 | &key (flip-uvs-vertically nil) 188 | (color-scale (v! 1 1 1 1))) 189 | (draw-tex-tr sampler/tex 190 | :flip-uvs-vertically flip-uvs-vertically 191 | :color-scale color-scale)) 192 | 193 | (defmethod draw-tex-tr ((sampler sampler) 194 | &key (flip-uvs-vertically nil) 195 | (color-scale (v! 1 1 1 1))) 196 | (if (eq (sampler-type sampler) :sampler-cube) 197 | (%draw-cube-face sampler (v! 0.5 0.5) 1.5707 0.5 color-scale) 198 | (%draw-sampler sampler (v! 0.5 0.5) 0s0 0.5 flip-uvs-vertically color-scale))) 199 | 200 | ;;------------------------------------------------------------ 201 | 202 | (defun draw-tex-bottom-right (sampler/tex 203 | &key (flip-uvs-vertically nil) 204 | (color-scale (v! 1 1 1 1))) 205 | (draw-tex-br sampler/tex 206 | :flip-uvs-vertically flip-uvs-vertically 207 | :color-scale color-scale)) 208 | 209 | (defmethod draw-tex-br ((sampler sampler) 210 | &key (flip-uvs-vertically nil) 211 | (color-scale (v! 1 1 1 1))) 212 | (if (eq (sampler-type sampler) :sampler-cube) 213 | (%draw-cube-face sampler (v! 0.5 -0.5) 1.5707 0.5 color-scale) 214 | (%draw-sampler sampler (v! 0.5 -0.5) 0s0 0.5 flip-uvs-vertically color-scale))) 215 | 216 | ;;------------------------------------------------------------ 217 | 218 | (defun-g draw-texture-at-vert ((vert g-pt) &uniform (pos :vec2) 219 | (size :vec2) 220 | (viewport-size :vec2) 221 | (uv-flip :bool)) 222 | (let* ((vpos (* (s~ (pos vert) :xy) 2)) 223 | (scaled-pos (/ (* vpos size) viewport-size)) 224 | (final (v! (+ pos scaled-pos) 0f0 1f0)) 225 | (uv-y (if uv-flip 226 | (- 1 (y (tex vert))) 227 | (y (tex vert))))) 228 | (values final (v! (x (tex vert)) uv-y)))) 229 | 230 | (defun-g draw-texture-at-frag ((tc :vec2) &uniform (tex :sampler-2d) 231 | (color-scale :vec4)) 232 | (* (texture tex tc) color-scale)) 233 | 234 | (defpipeline-g draw-texture-at-pipeline () 235 | #'(draw-texture-at-vert g-pt) 236 | #'(draw-texture-at-frag :vec2)) 237 | 238 | (defmethod draw-tex-at ((sampler sampler) 239 | &key 240 | (pos (v! 0 0)) 241 | (centered t) 242 | (flip-uvs-vertically nil) 243 | (color-scale (v! 1 1 1 1))) 244 | (let* ((size (v! (texture-base-dimensions (sampler-texture sampler)))) 245 | (vp-size (viewport-resolution (current-viewport))) 246 | (ratio (v2:/ size vp-size)) 247 | (pos (if centered 248 | pos 249 | (v2:+ pos (v! (x ratio) 0))))) 250 | (map-g #'draw-texture-at-pipeline (nineveh.internals:get-gpu-quad) 251 | :tex sampler 252 | :size size 253 | :pos pos 254 | :viewport-size vp-size 255 | :uv-flip (if flip-uvs-vertically 1 0) 256 | :color-scale color-scale))) 257 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (uiop:define-package #:nineveh.internals 4 | (:use #:cl :glsl-symbols #:cepl 5 | #:rtg-math #:rtg-math.base-maths 6 | #:vari) 7 | (:import-from :varjo :dbind :vbind :dbind* :vbind* :symb) 8 | (:export :get-gpu-quad)) 9 | 10 | (uiop:define-package #:nineveh.math-primitives 11 | (:use #:cl :glsl-symbols #:cepl 12 | #:rtg-math #:rtg-math.base-maths 13 | #:vari) 14 | (:import-from :varjo :dbind :vbind :dbind* :vbind* :symb) 15 | (:export :log10 16 | :atan2 17 | :vmax 18 | :saturate 19 | :mod-fixed-denominator 20 | :mod-fixed-denominator-low-quality 21 | :remap 22 | :remap-uv 23 | :radical-inverse-vdc)) 24 | 25 | (uiop:define-package #:nineveh.conditionals 26 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math :rtg-math.base-maths 27 | #:vari #:nineveh.math-primitives) 28 | (:import-from :varjo :dbind :vbind :dbind* :vbind* :symb) 29 | (:export :mix-step-if)) 30 | 31 | (uiop:define-package #:nineveh.color 32 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math :rtg-math.base-maths 33 | #:nineveh.math-primitives 34 | :nineveh.conditionals) 35 | (:import-from :varjo :dbind :vbind :dbind* :vbind* :symb) 36 | (:export :rgb->greyscale 37 | :hue->rgb 38 | :rgb->hcv 39 | :rgb->hsv 40 | :hsv->rgb 41 | :rgb->hsl 42 | :hsl->rgb 43 | :rgb->hcy 44 | :hcy->rgb 45 | :rgb->hcl 46 | :rgb->luma-bt709 47 | :rgb->luma-bt601 48 | :rgb->luma-low-accuracy-0 49 | :rgb->luma-low-accuracy-1 50 | :apply-luminance)) 51 | 52 | (uiop:define-package #:nineveh.hashing 53 | (:use #:cl :glsl-symbols #:cepl :vari #:rtg-math :rtg-math.base-maths 54 | :nineveh.math-primitives) 55 | (:import-from :varjo :dbind :vbind :dbind* :vbind* :symb) 56 | (:export :blum-blum-shub-hash 57 | :blum-blum-shub-hash-low-quality 58 | ;; 59 | :bs-fast32-hash 60 | :bs-fast32-hash-2-per-corner 61 | :bs-fast32-hash-3-per-corner 62 | :bs-fast32-hash-4-per-corner 63 | :bs-fast32-hash-cell 64 | ;; 65 | :bs-quick32-hash 66 | :bs-quick32-hash-4-per-corner 67 | ;; 68 | :sgim-qpp-hash 69 | :sgim-qpp-hash-2-per-corner 70 | :sgim-qpp-hash-3-per-corner)) 71 | 72 | (uiop:define-package #:nineveh.shaping-functions 73 | (:use #:cl :glsl-symbols #:cepl :vari #:rtg-math :rtg-math.base-maths) 74 | (:import-from :varjo 75 | :dbind :vbind :dbind* :vbind* :symb) 76 | (:import-from :cepl-utils 77 | :with-setf) 78 | (:export :cos-raised-inverted-blinn-wybill 79 | :seat-double-cubic 80 | :seat-double-cubic-with-linear-bend 81 | :seat-double-odd-exponent 82 | ;; 83 | :almost-identity 84 | :cubic-pulse 85 | :exponential-step 86 | :impulse 87 | :parabola 88 | :power-curve 89 | ;; 90 | :hermine 91 | :quintic 92 | :quintic-deriv 93 | :quintic-fast 94 | :quintic-interp-and-deriv 95 | :quintic-hermite 96 | :quintic-hermite-deriv 97 | ;; 98 | :falloff-xsq-c1 99 | :falloff-xsq-c2 100 | :falloff-xsq-c2 101 | ;; 102 | :inverse-square)) 103 | 104 | (uiop:define-package #:nineveh.noise 105 | (:use #:cl :glsl-symbols #:cepl :vari #:rtg-math :rtg-math.base-maths 106 | :nineveh.math-primitives 107 | :nineveh.shaping-functions 108 | :nineveh.hashing) 109 | (:import-from :varjo :dbind :vbind :dbind* :vbind* :symb) 110 | (:export :value-noise 111 | :value-noise-deriv 112 | ;; 113 | :perlin-noise 114 | :perlin-noise-surflet 115 | :perlin-noise-revised 116 | :perlin-noise-simplex 117 | :perlin-noise-deriv 118 | :perlin-noise-surflet-deriv 119 | :perlin-noise-simplex-deriv 120 | ;; 121 | :value-perlin-noise 122 | ;; 123 | :cubist-noise 124 | ;; 125 | :cellular-noise 126 | :cellular-noise-fast 127 | :cellular-noise-simplex 128 | ;; 129 | :polka-dot-noise 130 | :polka-dot-noise-simplex 131 | :stars-noise 132 | ;; 133 | :hermite-noise 134 | :hermite-noise-unnormalized-gradients 135 | :hermite-noise-deriv 136 | :hermite-noise-unnormalized-gradients-deriv 137 | ;; 138 | :value-hermite-noise)) 139 | 140 | (uiop:define-package #:nineveh.random 141 | (:use #:cl :glsl-symbols #:cepl :vari #:rtg-math :rtg-math.base-maths 142 | :nineveh.math-primitives 143 | :nineveh.shaping-functions) 144 | (:import-from :varjo :dbind :vbind :dbind* :vbind* :symb) 145 | (:export :rand 146 | :hammersley-nth-2d 147 | :hammersley-nth-hemisphere)) 148 | 149 | (uiop:define-package :nineveh.mesh.data.primitives 150 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math #:rtg-math.base-maths 151 | #:nineveh.math-primitives 152 | #:dendrite.primitives) 153 | (:import-from :varjo 154 | :dbind :vbind :dbind* :vbind* :symb) 155 | (:import-from :cepl-utils 156 | :with-setf) 157 | (:export :lattice-c-arrays 158 | :lattice-gpu-arrays 159 | :box-c-arrays 160 | :box-gpu-arrays 161 | :cone-c-arrays 162 | :cone-gpu-arrays 163 | :cylinder-c-arrays 164 | :cylinder-gpu-arrays 165 | :plain-gpu-arrays 166 | :plain-c-arrays 167 | :cube-gpu-arrays 168 | :cube-c-arrays 169 | :sphere-gpu-arrays 170 | :sphere-c-arrays)) 171 | 172 | (uiop:define-package #:nineveh.easing 173 | (:use #:cl :glsl-symbols #:cepl :vari #:rtg-math :rtg-math.base-maths 174 | #:easing-f) 175 | (:reexport :easing)) 176 | 177 | (uiop:define-package #:nineveh.graphing 178 | (:use #:cl :glsl-symbols #:cepl :vari #:rtg-math :rtg-math.base-maths 179 | #:with-setf) 180 | (:export :graph 181 | :axis 182 | :plot 183 | :define-pgraph)) 184 | 185 | (uiop:define-package #:nineveh.normals 186 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math :rtg-math.base-maths) 187 | (:import-from :varjo :dbind :vbind :dbind* :vbind* :symb) 188 | (:export :simple-sample-normals)) 189 | 190 | (uiop:define-package #:nineveh.textures 191 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math :rtg-math.base-maths) 192 | (:import-from :varjo :dbind :vbind :dbind* :vbind* :symb) 193 | (:export :sample-equirectangular-tex 194 | :uv->cube-map-directions 195 | ;; 196 | :draw-tex 197 | :draw-tex-tl 198 | :draw-tex-tr 199 | :draw-tex-bl 200 | :draw-tex-br 201 | :draw-tex-top-left 202 | :draw-tex-top-right 203 | :draw-tex-bottom-left 204 | :draw-tex-bottom-right 205 | :dirty-blit-sampler 206 | ;; 207 | :load-hdr-cross-image 208 | :load-hdr-cross-texture 209 | :load-hdr-2d 210 | ;; 211 | :make-fbos-for-each-mipmap-of-cube-texture 212 | :cube-faces)) 213 | 214 | (uiop:define-package #:nineveh.streams 215 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math :rtg-math.base-maths 216 | :cepl.defn) 217 | (:import-from :varjo 218 | :dbind :vbind :dbind* :vbind* :symb) 219 | (:import-from :uiop 220 | :ensure-list) 221 | (:export :get-quad-stream-v2 222 | :buffer-streamer 223 | :make-buffer-streamer 224 | :buffer-streamer-push 225 | :buffer-streamer-push-from-range)) 226 | 227 | (uiop:define-package #:nineveh.vignette 228 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math :rtg-math.base-maths 229 | :cepl.defn) 230 | (:import-from :varjo 231 | :dbind :vbind :dbind* :vbind* :symb) 232 | (:import-from :uiop 233 | :ensure-list) 234 | (:export :vignette :natural-vignette)) 235 | 236 | (uiop:define-package #:nineveh.anti-aliasing 237 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math :rtg-math.base-maths 238 | :cepl.defn) 239 | (:import-from :varjo 240 | :dbind :vbind :dbind* :vbind* :symb) 241 | (:import-from :uiop 242 | :ensure-list) 243 | (:export :fxaa2 :fxaa2-calc-uvs 244 | :fxaa3 :fxaa3-pass)) 245 | 246 | (uiop:define-package #:nineveh.distortion 247 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math :rtg-math.base-maths 248 | :cepl.defn) 249 | (:import-from :varjo 250 | :dbind :vbind :dbind* :vbind* :symb) 251 | (:import-from :uiop 252 | :ensure-list) 253 | (:export :radial-distort 254 | :barrel-distortion 255 | :brown-conrady-distortion)) 256 | 257 | (uiop:define-package #:nineveh.tonemapping 258 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math :rtg-math.base-maths 259 | :nineveh.math-primitives) 260 | (:import-from :varjo 261 | :dbind :vbind :dbind* :vbind* :symb) 262 | (:import-from :cepl-utils 263 | :with-setf) 264 | (:export :tone-map-linear 265 | :tone-map-reinhard 266 | :tone-map-haarm-peter-duiker 267 | :tone-map-hejl-burgess-dawson 268 | :tone-map-uncharted2)) 269 | 270 | (uiop:define-package #:nineveh.sdf.2d 271 | (:use #:cl :glsl-symbols #:cepl #:vari #:rtg-math :rtg-math.base-maths 272 | :nineveh.math-primitives) 273 | (:import-from :varjo 274 | :dbind :vbind :dbind* :vbind* :symb) 275 | (:import-from :cepl-utils 276 | :with-setf) 277 | (:export :circle 278 | :intersect 279 | :line 280 | :mask-border-inner 281 | :mask-border-outer 282 | :mask-fill 283 | :merge-exclude 284 | :merge-simple 285 | :merge-smooth 286 | :pie 287 | :point-light 288 | :point-light-with-source 289 | :rectangle 290 | :rhombus 291 | :hexagon 292 | :fast-rect 293 | :rotate-ccw 294 | :semicircle 295 | :subtract 296 | :translate 297 | :triangle)) 298 | 299 | (uiop:define-package #:nineveh 300 | (:use #:cl :glsl-symbols #:cepl :vari #:rtg-math :rtg-math.base-maths 301 | :nineveh.color 302 | :nineveh.conditionals 303 | :nineveh.graphing 304 | :nineveh.hashing 305 | :nineveh.math-primitives 306 | :nineveh.noise 307 | :nineveh.normals 308 | :nineveh.random 309 | :nineveh.shaping-functions 310 | :nineveh.streams 311 | :nineveh.textures 312 | :nineveh.tonemapping) 313 | (:import-from :varjo 314 | :dbind :vbind :dbind* :vbind* :symb) 315 | (:import-from :cepl-utils 316 | :with-setf) 317 | (:reexport :nineveh.color 318 | :nineveh.conditionals 319 | :nineveh.graphing 320 | :nineveh.hashing 321 | :nineveh.math-primitives 322 | :nineveh.noise 323 | :nineveh.normals 324 | :nineveh.random 325 | :nineveh.shaping-functions 326 | :nineveh.streams 327 | :nineveh.textures 328 | :nineveh.tonemapping) 329 | (:export 330 | :as-frame 331 | :def-simple-main-loop 332 | :define-simple-main-loop)) 333 | -------------------------------------------------------------------------------- /hashing/bsharpe-fast-32-hash.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.hashing) 2 | 3 | ;; 4 | ;; FAST32_hash 5 | ;; A very fast hashing function. Requires 32bit support. 6 | ;; http://briansharpe.wordpress.com/2011/11/15/a-fast-and-simple-32bit-floating-point-hash-function/ 7 | ;; 8 | ;; The 2D hash formula takes the form.... 9 | ;; hash = mod( coord.x * coord.x * coord.y * coord.y, SOMELARGEFLOAT ) 10 | ;; / SOMELARGEFLOAT 11 | ;; 12 | ;; We truncate and offset the domain to the most interesting part of the noise. 13 | ;; SOMELARGEFLOAT should be in the range of 400.0->1000.0 and needs to be hand 14 | ;; picked. Only some give good results. A 3D hash is achieved by offsetting 15 | ;; the SOMELARGEFLOAT value by the Z coordinate 16 | ;; 17 | 18 | ;;------------------------------------------------------------ 19 | ;; 2D 20 | 21 | (defun-g bs-fast32-hash ((grid-cell :vec2)) 22 | (let* ((offset (v2! 26.0 161.0)) 23 | (domain 71.0) 24 | (somelargefloat "951.135664") 25 | (p (v! (s~ grid-cell :xy) (+ (s~ grid-cell :xy) (v2! 1.0))))) 26 | (setf p (- p (* (floor (* p (/ 1.0 domain))) domain))) 27 | (incf p (s~ offset :xyxy)) 28 | (multf p p) 29 | (fract (* (s~ p :xzxz) (* (s~ p :yyww) (/ 1.0 somelargefloat)))))) 30 | 31 | (defun-g bs-fast32-hash-2-per-corner ((grid-cell :vec2)) 32 | (let* ((offset (v2! 26.0 161.0)) 33 | (domain 71.0) 34 | (some-large-floats (v! "951.135664" "642.949883")) 35 | (p (v! (s~ grid-cell :xy) (+ (s~ grid-cell :xy) (v2! 1.0))))) 36 | (setf p (- p (* (floor (* p (/ 1.0 domain))) domain))) 37 | (incf p (s~ offset :xyxy)) 38 | (multf p p) 39 | (setf p (* (s~ p :xzxz) (s~ p :yyww))) 40 | (values (fract (* p (/ 1.0 (x some-large-floats)))) 41 | (fract (* p (/ 1.0 (y some-large-floats))))))) 42 | 43 | (defun-g bs-fast32-hash-3-per-corner ((grid-cell :vec2)) 44 | (let* ((offset (v2! 26.0 161.0)) 45 | (domain 71.0) 46 | (some-large-floats (v! "951.135664" "642.949883" "803.202459")) 47 | (p (v! (s~ grid-cell :xy) (+ (s~ grid-cell :xy) (v2! 1.0))))) 48 | (setf p (- p (* (floor (* p (/ 1.0 domain))) domain))) 49 | (incf p (s~ offset :xyxy)) 50 | (multf p p) 51 | (setf p (* (s~ p :xzxz) (s~ p :yyww))) 52 | (values 53 | (fract (* p (/ 1.0 (x some-large-floats)))) 54 | (fract (* p (/ 1.0 (y some-large-floats)))) 55 | (fract (* p (/ 1.0 (z some-large-floats))))))) 56 | 57 | (defun-g bs-fast32-hash-cell ((grid-cell :vec2)) 58 | (let* ((offset (v2! 26.0 161.0)) 59 | (domain 71.0) 60 | (some-large-floats (v! "951.135664" 61 | "642.949883" 62 | "803.202459" 63 | "986.973274")) 64 | (p (- grid-cell (* (floor (* grid-cell (/ 1.0 domain))) domain)))) 65 | (incf p (s~ offset :xy)) 66 | (multf p p) 67 | (fract (* (* (x p) (y p)) (/ (v4! 1.0) (s~ some-large-floats :xyzw)))))) 68 | 69 | ;;------------------------------------------------------------ 70 | ;; 3D 71 | 72 | (defun-g bs-fast32-hash ((grid-cell :vec3)) 73 | (let* ((offset (v2! 50.0 161.0)) 74 | (domain 69.0) 75 | (somelargefloat "635.298681") 76 | (zinc "48.500388")) 77 | (setf (s~ grid-cell :xyz) 78 | (- (s~ grid-cell :xyz) 79 | (* (floor (* (s~ grid-cell :xyz) (/ 1.0 domain))) domain))) 80 | (let* ((grid-cell-inc1 81 | (* (step grid-cell (v3! (- domain 1.5))) (+ grid-cell (v3! 1.0)))) 82 | (p 83 | (+ (v! (s~ grid-cell :xy) (s~ grid-cell-inc1 :xy)) 84 | (s~ offset :xyxy))) 85 | ((lowz-hash :vec4)) 86 | (highz-hash (v4! 0))) 87 | (multf p p) 88 | (setf p (* (s~ p :xzxz) (s~ p :yyww))) 89 | (setf (s~ highz-hash :xy) 90 | (/ (v2! 1.0) 91 | (+ (v2! somelargefloat) 92 | (* (v2! (z grid-cell) (z grid-cell-inc1)) zinc)))) 93 | (setf lowz-hash (fract (* p (s~ highz-hash :xxxx)))) 94 | (setf highz-hash (fract (* p (s~ highz-hash :yyyy)))) 95 | (values lowz-hash highz-hash)))) 96 | 97 | 98 | (defun-g bs-fast32-hash ((grid-cell :vec3) (v1-mask :vec3) (v2-mask :vec3)) 99 | (let* ((offset (v2! 50.0 161.0)) 100 | (domain 69.0) 101 | (somelargefloat "635.298681") 102 | (zinc "48.500388")) 103 | (setf (s~ grid-cell :xyz) 104 | (- (s~ grid-cell :xyz) 105 | (* (floor (* (s~ grid-cell :xyz) (/ 1.0 domain))) domain))) 106 | (let* ((grid-cell-inc1 107 | (* (step grid-cell (v3! (- domain 1.5))) (+ grid-cell (v3! 1.0)))) 108 | (p 109 | (+ (v! (s~ grid-cell :xy) (s~ grid-cell-inc1 :xy)) 110 | (s~ offset :xyxy)))) 111 | (multf p p) 112 | (let* ((v1xy-v2xy 113 | (mix (s~ p :xyxy) (s~ p :zwzw) 114 | (v! (s~ v1-mask :xy) (s~ v2-mask :xy))))) 115 | (setf p 116 | (* (v! (x p) (s~ v1xy-v2xy :xz) (z p)) 117 | (v! (y p) (s~ v1xy-v2xy :yw) (w p)))) 118 | (let* ((v1z-v2z 119 | (v2! 120 | (if (< (z v1-mask) 0.5) 121 | (z grid-cell) 122 | (z grid-cell-inc1)) 123 | (if (< (z v2-mask) 0.5) 124 | (z grid-cell) 125 | (z grid-cell-inc1)))) 126 | (mod-vals 127 | (/ (v4! 1.0) 128 | (+ (v4! somelargefloat) 129 | (* (v! (z grid-cell) v1z-v2z (z grid-cell-inc1)) 130 | zinc))))) 131 | (fract (* p mod-vals))))))) 132 | 133 | (defun-g bs-fast32-hash-3-per-corner ((grid-cell :vec3)) 134 | (let* ((offset (v2! 50.0 161.0)) 135 | (domain 69.0) 136 | (some-large-floats (v! "635.298681" "682.357502" "668.926525")) 137 | (zinc (v! "48.500388" "65.294118" "63.934599"))) 138 | (setf (s~ grid-cell :xyz) 139 | (- (s~ grid-cell :xyz) 140 | (* (floor (* (s~ grid-cell :xyz) (/ 1.0 domain))) domain))) 141 | (let* ((grid-cell-inc1 (* (step grid-cell (v3! (- domain 1.5))) 142 | (+ grid-cell (v3! 1.0)))) 143 | (p (+ (v! (s~ grid-cell :xy) (s~ grid-cell-inc1 :xy)) 144 | (s~ offset :xyxy)))) 145 | (multf p p) 146 | (setf p (* (s~ p :xzxz) (s~ p :yyww))) 147 | (let* ((lowz-mod 148 | (/ (v3! 1.0) 149 | (+ (s~ some-large-floats :xyz) 150 | (* (s~ grid-cell :zzz) (s~ zinc :xyz))))) 151 | (highz-mod 152 | (/ (v3! 1.0) 153 | (+ (s~ some-large-floats :xyz) 154 | (* (s~ grid-cell-inc1 :zzz) (s~ zinc :xyz)))))) 155 | (values 156 | (fract (* p (s~ lowz-mod :xxxx))) ;; lowz-hash-0 157 | (fract (* p (s~ lowz-mod :yyyy))) ;; lowz-hash-1 158 | (fract (* p (s~ lowz-mod :zzzz))) ;; lowz-hash-2 159 | (fract (* p (s~ highz-mod :xxxx))) ;; highz-hash-0 160 | (fract (* p (s~ highz-mod :yyyy))) ;; highz-hash-1 161 | (fract (* p (s~ highz-mod :zzzz)))))))) ;; highz-hash-2 162 | 163 | 164 | (defun-g bs-fast32-hash-3-per-corner ((grid-cell :vec3) 165 | (v1-mask :vec3) 166 | (v2-mask :vec3)) 167 | (let* ((offset (v2! 50.0 161.0)) 168 | (domain 69.0) 169 | (some-large-floats (v! "635.298681" "682.357502" "668.926525")) 170 | (zinc (v! "48.500388" "65.294118" "63.934599"))) 171 | (setf (s~ grid-cell :xyz) 172 | (- (s~ grid-cell :xyz) 173 | (* (floor (* (s~ grid-cell :xyz) (/ 1.0 domain))) domain))) 174 | (let* ((grid-cell-inc1 175 | (* (step grid-cell (v3! (- domain 1.5))) (+ grid-cell (v3! 1.0)))) 176 | (p 177 | (+ (v! (s~ grid-cell :xy) (s~ grid-cell-inc1 :xy)) 178 | (s~ offset :xyxy)))) 179 | (multf p p) 180 | (let* ((v1xy-v2xy 181 | (mix (s~ p :xyxy) (s~ p :zwzw) 182 | (v! (s~ v1-mask :xy) (s~ v2-mask :xy))))) 183 | (setf p 184 | (* (v! (x p) (s~ v1xy-v2xy :xz) (z p)) 185 | (v! (y p) (s~ v1xy-v2xy :yw) (w p)))) 186 | (let* ((lowz-mods 187 | (/ (v3! 1.0) 188 | (+ (s~ some-large-floats :xyz) 189 | (* (s~ grid-cell :zzz) (s~ zinc :xyz))))) 190 | (highz-mods 191 | (/ (v3! 1.0) 192 | (+ (s~ some-large-floats :xyz) 193 | (* (s~ grid-cell-inc1 :zzz) (s~ zinc :xyz)))))) 194 | (setf v1-mask 195 | (if (< (z v1-mask) 0.5) 196 | lowz-mods 197 | highz-mods)) 198 | (setf v2-mask 199 | (if (< (z v2-mask) 0.5) 200 | lowz-mods 201 | highz-mods)) 202 | (values 203 | (fract 204 | (* p 205 | (v4! (x lowz-mods) (x v1-mask) (x v2-mask) 206 | (x highz-mods)))) 207 | (fract 208 | (* p 209 | (v4! (y lowz-mods) (y v1-mask) (y v2-mask) 210 | (y highz-mods)))) 211 | (fract 212 | (* p 213 | (v4! (z lowz-mods) (z v1-mask) (z v2-mask) 214 | (z highz-mods)))))))))) 215 | 216 | (defun-g bs-fast32-hash-4-per-corner ((grid-cell :vec3)) 217 | (let (((lowz-hash-0 :vec4)) 218 | ((lowz-hash-1 :vec4)) 219 | ((lowz-hash-2 :vec4)) 220 | (lowz-hash-3 (v4! 0)) 221 | ((highz-hash-0 :vec4)) 222 | ((highz-hash-1 :vec4)) 223 | ((highz-hash-2 :vec4)) 224 | (highz-hash-3 (v4! 0))) 225 | (let* ((offset (v2! 50.0 161.0)) 226 | (domain 69.0) 227 | (some-large-floats (v! "635.298681" 228 | "682.357502" 229 | "668.926525" 230 | "588.255119")) 231 | (zinc (v! "48.500388" "65.294118" "63.934599" "63.279683"))) 232 | (setf (s~ grid-cell :xyz) 233 | (- (s~ grid-cell :xyz) 234 | (* (floor (* (s~ grid-cell :xyz) (/ 1.0 domain))) domain))) 235 | (let* ((grid-cell-inc1 236 | (* (step grid-cell (v3! (- domain 1.5))) (+ grid-cell (v3! 1.0)))) 237 | (p 238 | (+ (v! (s~ grid-cell :xy) (s~ grid-cell-inc1 :xy)) 239 | (s~ offset :xyxy)))) 240 | (multf p p) 241 | (setf p (* (s~ p :xzxz) (s~ p :yyww))) 242 | (setf (s~ lowz-hash-3 :xyzw) 243 | (/ (v4! 1.0) 244 | (+ (s~ some-large-floats :xyzw) 245 | (* (s~ grid-cell :zzzz) (s~ zinc :xyzw))))) 246 | (setf (s~ highz-hash-3 :xyzw) 247 | (/ (v4! 1.0) 248 | (+ (s~ some-large-floats :xyzw) 249 | (* (s~ grid-cell-inc1 :zzzz) (s~ zinc :xyzw))))) 250 | (setf lowz-hash-0 (fract (* p (s~ lowz-hash-3 :xxxx)))) 251 | (setf highz-hash-0 (fract (* p (s~ highz-hash-3 :xxxx)))) 252 | (setf lowz-hash-1 (fract (* p (s~ lowz-hash-3 :yyyy)))) 253 | (setf highz-hash-1 (fract (* p (s~ highz-hash-3 :yyyy)))) 254 | (setf lowz-hash-2 (fract (* p (s~ lowz-hash-3 :zzzz)))) 255 | (setf highz-hash-2 (fract (* p (s~ highz-hash-3 :zzzz)))) 256 | (setf lowz-hash-3 (fract (* p (s~ lowz-hash-3 :wwww)))) 257 | (setf highz-hash-3 (fract (* p (s~ highz-hash-3 :wwww)))))) 258 | (values lowz-hash-0 lowz-hash-1 lowz-hash-2 lowz-hash-3 259 | highz-hash-0 highz-hash-1 highz-hash-2 highz-hash-3))) 260 | 261 | (defun-g bs-fast32-hash-cell ((grid-cell :vec3)) 262 | (let* ((offset (v2! 50.0 161.0)) 263 | (domain 69.0) 264 | (some-large-floats (v! "635.298681" 265 | "682.357502" 266 | "668.926525" 267 | "588.255119")) 268 | (zinc (v! "48.500388" "65.294118" "63.934599" "63.279683"))) 269 | (setf (s~ grid-cell :xyz) 270 | (- grid-cell (* (floor (* grid-cell (/ 1.0 domain))) domain))) 271 | (incf (s~ grid-cell :xy) (s~ offset :xy)) 272 | (multf (s~ grid-cell :xy) (s~ grid-cell :xy)) 273 | (fract 274 | (* (x grid-cell) 275 | (y grid-cell) 276 | (/ (v4! 1.0) (+ some-large-floats 277 | (* (s~ grid-cell :zzzz) 278 | zinc))))))) 279 | 280 | ;;------------------------------------------------------------ 281 | -------------------------------------------------------------------------------- /noise/cellular.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.noise) 2 | 3 | ;;---------------------------------------------------------------------- 4 | 5 | (defun-g cellular-weight-samples ((samples :vec4)) 6 | (setf samples (- (* samples 2.0) (v4! 1.0))) 7 | (- (* samples (* samples samples)) (sign samples))) 8 | 9 | ;;---------------------------------------------------------------------- 10 | ;; 2D 11 | 12 | (defun-g cellular-noise ((p :vec2)) 13 | (let* ((pi (floor p)) 14 | (pf (- p pi))) 15 | (multiple-value-bind (hash-x hash-y) (bs-fast32-hash-2-per-corner pi) 16 | (let* ((jitter-window 0.25)) 17 | (setf hash-x 18 | (+ (* (cellular-weight-samples hash-x) jitter-window) 19 | (v4! 0.0 1.0 0.0 1.0))) 20 | (setf hash-y 21 | (+ (* (cellular-weight-samples hash-y) jitter-window) 22 | (v4! 0.0 0.0 1.0 1.0))) 23 | (let* ((dx (- (s~ pf :xxxx) hash-x)) 24 | (dy (- (s~ pf :yyyy) hash-y)) 25 | (d (+ (* dx dx) (* dy dy)))) 26 | (setf (s~ d :xy) (min (s~ d :xy) (s~ d :zw))) 27 | (* (min (x d) (y d)) (/ 1.0 1.125))))))) 28 | 29 | (defun-g cellular-noise-deriv ((p :vec2)) 30 | (let* ((pi (floor p)) 31 | (pf (- p pi))) 32 | (multiple-value-bind (hash-x hash-y) (bs-fast32-hash-2-per-corner pi) 33 | (let* ((jitter-window 0.25)) 34 | (setf hash-x 35 | (+ (* (cellular-weight-samples hash-x) jitter-window) 36 | (v4! 0.0 1.0 0.0 1.0))) 37 | (setf hash-y 38 | (+ (* (cellular-weight-samples hash-y) jitter-window) 39 | (v4! 0.0 0.0 1.0 1.0))) 40 | (let* ((dx (- (s~ pf :xxxx) hash-x)) 41 | (dy (- (s~ pf :yyyy) hash-y)) 42 | (d (+ (* dx dx) (* dy dy))) 43 | (t1 44 | (if (< (x d) (y d)) 45 | (v3! (x d) (x dx) (x dy)) 46 | (v3! (y d) (y dx) (y dy)))) 47 | (t2 48 | (if (< (z d) (w d)) 49 | (v3! (z d) (z dx) (z dy)) 50 | (v3! (w d) (w dx) (w dy))))) 51 | (* 52 | (if (< (x t1) (x t2)) 53 | t1 54 | t2) 55 | (* (v3! 1.0 2.0 2.0) (/ 1.0 1.125)))))))) 56 | 57 | (defun-g cellular-noise-fast ((p :vec2)) 58 | (let* ((pi (floor p)) 59 | (pf (- p pi))) 60 | (multiple-value-bind (hash-x hash-y) (bs-fast32-hash-2-per-corner pi) 61 | (let* ((jitter-window 0.4)) 62 | (setf hash-x 63 | (+ (* hash-x (* jitter-window 2.0)) 64 | (v4! (- jitter-window) (- 1.0 jitter-window) 65 | (- jitter-window) (- 1.0 jitter-window)))) 66 | (setf hash-y 67 | (+ (* hash-y (* jitter-window 2.0)) 68 | (v4! (- jitter-window) (- jitter-window) 69 | (- 1.0 jitter-window) (- 1.0 jitter-window)))) 70 | (let* ((dx (- (s~ pf :xxxx) hash-x)) 71 | (dy (- (s~ pf :yyyy) hash-y)) 72 | (d (+ (* dx dx) (* dy dy)))) 73 | (setf (s~ d :xy) (min (s~ d :xy) (s~ d :zw))) 74 | (* (min (x d) (y d)) (/ 1.0 1.125))))))) 75 | 76 | (defun-g cellular-noise-simplex ((p :vec2)) 77 | (let* ((skew-factor 0.36602542) 78 | (unskew-factor 0.21132489) 79 | (simplex-tri-height 0.7071068) 80 | (inv-simplex-tri-height "1.4142135623730950488016887242097") 81 | (simplex-points 82 | (* 83 | (v3! (- 1.0 unskew-factor) (- unskew-factor) 84 | (- 1.0 (* 2.0 unskew-factor))) 85 | inv-simplex-tri-height))) 86 | (multf p (v2! simplex-tri-height)) 87 | (let* ((pi (floor (+ p (v2! (dot p (v2! skew-factor)))))) 88 | (jitter-window (* 0.10566244 inv-simplex-tri-height)) 89 | (p0 (* (- (- pi (v2! (dot pi (v2! unskew-factor)))) p) 90 | inv-simplex-tri-height))) 91 | (multiple-value-bind (hash-x hash-y) (bs-fast32-hash-2-per-corner pi) 92 | (setf hash-x (* (cellular-weight-samples hash-x) jitter-window)) 93 | (setf hash-y (* (cellular-weight-samples hash-y) jitter-window)) 94 | (incf hash-x (s~ p0 :xxxx)) 95 | (incf hash-y (s~ p0 :yyyy)) 96 | (incf (s~ hash-x :yzw) (s~ simplex-points :xyz)) 97 | (incf (s~ hash-y :yzw) (s~ simplex-points :yxz)) 98 | (let* ((distsq (+ (* hash-x hash-x) (* hash-y hash-y))) 99 | (tmp (min (s~ distsq :xy) (s~ distsq :zw)))) 100 | (min (x tmp) (y tmp))))))) 101 | 102 | ;;---------------------------------------------------------------------- 103 | ;; 3D 104 | 105 | (defun-g cellular-noise ((p :vec3)) 106 | (let* ((pi (floor p)) 107 | (pf (- p pi))) 108 | (multiple-value-bind (hash-x0 hash-y0 hash-z0 hash-x1 hash-y1 hash-z1) 109 | (bs-fast32-hash-3-per-corner pi) 110 | (let* ((jitter-window "0.166666666")) 111 | (setf hash-x0 112 | (+ (* (cellular-weight-samples hash-x0) jitter-window) 113 | (v4! 0.0 1.0 0.0 1.0))) 114 | (setf hash-y0 115 | (+ (* (cellular-weight-samples hash-y0) jitter-window) 116 | (v4! 0.0 0.0 1.0 1.0))) 117 | (setf hash-x1 118 | (+ (* (cellular-weight-samples hash-x1) jitter-window) 119 | (v4! 0.0 1.0 0.0 1.0))) 120 | (setf hash-y1 121 | (+ (* (cellular-weight-samples hash-y1) jitter-window) 122 | (v4! 0.0 0.0 1.0 1.0))) 123 | (progn 124 | (setf hash-z0 125 | (+ (* (cellular-weight-samples hash-z0) jitter-window) 126 | (v4! 0.0 0.0 0.0 0.0))) 127 | (setf hash-z1 128 | (+ (* (cellular-weight-samples hash-z1) jitter-window) 129 | (v4! 1.0 1.0 1.0 1.0))) 130 | (let* ((dx1 (- (s~ pf :xxxx) hash-x0)) 131 | (dy1 (- (s~ pf :yyyy) hash-y0)) 132 | (dz1 (- (s~ pf :zzzz) hash-z0)) 133 | (dx2 (- (s~ pf :xxxx) hash-x1)) 134 | (dy2 (- (s~ pf :yyyy) hash-y1)) 135 | (dz2 (- (s~ pf :zzzz) hash-z1)) 136 | (d1 (+ (* dx1 dx1) (+ (* dy1 dy1) (* dz1 dz1)))) 137 | (d2 (+ (* dx2 dx2) (+ (* dy2 dy2) (* dz2 dz2))))) 138 | (setf d1 (min d1 d2)) 139 | (setf (s~ d1 :xy) (min (s~ d1 :xy) (s~ d1 :wz))) 140 | (* (min (x d1) (y d1)) (/ 9.0 12.0)))))))) 141 | 142 | (defun-g cellular-noise-deriv ((p :vec3)) 143 | (let* ((pi (floor p)) 144 | (pf (- p pi))) 145 | (multiple-value-bind (hash-x0 hash-y0 hash-z0 hash-x1 hash-y1 hash-z1) 146 | (bs-fast32-hash-3-per-corner pi) 147 | (let* ((jitter-window "0.166666666")) 148 | (setf hash-x0 149 | (+ (* (cellular-weight-samples hash-x0) jitter-window) 150 | (v4! 0.0 1.0 0.0 1.0))) 151 | (setf hash-y0 152 | (+ (* (cellular-weight-samples hash-y0) jitter-window) 153 | (v4! 0.0 0.0 1.0 1.0))) 154 | (setf hash-x1 155 | (+ (* (cellular-weight-samples hash-x1) jitter-window) 156 | (v4! 0.0 1.0 0.0 1.0))) 157 | (setf hash-y1 158 | (+ (* (cellular-weight-samples hash-y1) jitter-window) 159 | (v4! 0.0 0.0 1.0 1.0))) 160 | (progn 161 | (setf hash-z0 162 | (+ (* (cellular-weight-samples hash-z0) jitter-window) 163 | (v4! 0.0 0.0 0.0 0.0))) 164 | (setf hash-z1 165 | (+ (* (cellular-weight-samples hash-z1) jitter-window) 166 | (v4! 1.0 1.0 1.0 1.0))) 167 | (let* ((dx1 (- (s~ pf :xxxx) hash-x0)) 168 | (dy1 (- (s~ pf :yyyy) hash-y0)) 169 | (dz1 (- (s~ pf :zzzz) hash-z0)) 170 | (dx2 (- (s~ pf :xxxx) hash-x1)) 171 | (dy2 (- (s~ pf :yyyy) hash-y1)) 172 | (dz2 (- (s~ pf :zzzz) hash-z1)) 173 | (d1 (+ (* dx1 dx1) (+ (* dy1 dy1) (* dz1 dz1)))) 174 | (d2 (+ (* dx2 dx2) (+ (* dy2 dy2) (* dz2 dz2)))) 175 | (r1 176 | (if (< (x d1) (y d1)) 177 | (v4! (x d1) (x dx1) (x dy1) (x dz1)) 178 | (v4! (y d1) (y dx1) (y dy1) (y dz1)))) 179 | (r2 180 | (if (< (z d1) (w d1)) 181 | (v4! (z d1) (z dx1) (z dy1) (z dz1)) 182 | (v4! (w d1) (w dx1) (w dy1) (w dz1)))) 183 | (r3 184 | (if (< (x d2) (y d2)) 185 | (v4! (x d2) (x dx2) (x dy2) (x dz2)) 186 | (v4! (y d2) (y dx2) (y dy2) (y dz2)))) 187 | (r4 188 | (if (< (z d2) (w d2)) 189 | (v4! (z d2) (z dx2) (z dy2) (z dz2)) 190 | (v4! (w d2) (w dx2) (w dy2) (w dz2)))) 191 | (t1 192 | (if (< (x r1) (x r2)) 193 | r1 194 | r2)) 195 | (t2 196 | (if (< (x r3) (x r4)) 197 | r3 198 | r4))) 199 | (* (if (< (x t1) (x t2)) 200 | t1 201 | t2) 202 | (* (v! 1.0 (v3! 2.0)) (/ 9.0 12.0))))))))) 203 | 204 | (defun-g cellular-noise-simplex ((p :vec3)) 205 | (multiple-value-bind (pi pi-1 pi-2 v1234-x v1234-y v1234-z) 206 | (simplex-3d-get-corner-vectors p) 207 | (multiple-value-bind (hash-x hash-y hash-z) 208 | (bs-fast32-hash-3-per-corner pi pi-1 pi-2) 209 | (let* ((inv-simplex-pyramid-height "1.4142135623730950488016887242097") 210 | (jitter-window (* 0.059786577 inv-simplex-pyramid-height))) 211 | (setf hash-x (* (cellular-weight-samples hash-x) jitter-window)) 212 | (setf hash-y (* (cellular-weight-samples hash-y) jitter-window)) 213 | (setf hash-z (* (cellular-weight-samples hash-z) jitter-window)) 214 | (multf v1234-x (v4! inv-simplex-pyramid-height)) 215 | (multf v1234-y (v4! inv-simplex-pyramid-height)) 216 | (multf v1234-z (v4! inv-simplex-pyramid-height)) 217 | (incf v1234-x hash-x) 218 | (progn 219 | (incf v1234-y hash-y) 220 | (incf v1234-z hash-z) 221 | (let* ((distsq 222 | (+ (* v1234-x v1234-x) 223 | (+ (* v1234-y v1234-y) (* v1234-z v1234-z))))) 224 | (min (min (x distsq) (y distsq)) 225 | (min (z distsq) (w distsq))))))))) 226 | 227 | (defun-g cellular-noise-fast ((p :vec3)) 228 | (let* ((pi (floor p)) 229 | (pf (- p pi))) 230 | (multiple-value-bind (hash-x0 hash-y0 hash-z0 hash-x1 hash-y1 hash-z1) 231 | (bs-fast32-hash-3-per-corner pi) 232 | (let* ((jitter-window 0.4)) 233 | (setf hash-x0 234 | (+ (* hash-x0 (* jitter-window 2.0)) 235 | (v4! (- jitter-window) (- 1.0 jitter-window) 236 | (- jitter-window) (- 1.0 jitter-window)))) 237 | (setf hash-y0 238 | (+ (* hash-y0 (* jitter-window 2.0)) 239 | (v4! (- jitter-window) (- jitter-window) 240 | (- 1.0 jitter-window) (- 1.0 jitter-window)))) 241 | (setf hash-x1 242 | (+ (* hash-x1 (* jitter-window 2.0)) 243 | (v4! (- jitter-window) (- 1.0 jitter-window) 244 | (- jitter-window) (- 1.0 jitter-window)))) 245 | (setf hash-y1 246 | (+ (* hash-y1 (* jitter-window 2.0)) 247 | (v4! (- jitter-window) (- jitter-window) 248 | (- 1.0 jitter-window) (- 1.0 jitter-window)))) 249 | (progn 250 | (setf hash-z0 251 | (+ (* hash-z0 (* jitter-window 2.0)) 252 | (v4! (- jitter-window) (- jitter-window) 253 | (- jitter-window) (- jitter-window)))) 254 | (setf hash-z1 255 | (+ (* hash-z1 (* jitter-window 2.0)) 256 | (v4! (- 1.0 jitter-window) (- 1.0 jitter-window) 257 | (- 1.0 jitter-window) (- 1.0 jitter-window)))) 258 | (let* ((dx1 (- (s~ pf :xxxx) hash-x0)) 259 | (dy1 (- (s~ pf :yyyy) hash-y0)) 260 | (dz1 (- (s~ pf :zzzz) hash-z0)) 261 | (dx2 (- (s~ pf :xxxx) hash-x1)) 262 | (dy2 (- (s~ pf :yyyy) hash-y1)) 263 | (dz2 (- (s~ pf :zzzz) hash-z1)) 264 | (d1 (+ (* dx1 dx1) (+ (* dy1 dy1) (* dz1 dz1)))) 265 | (d2 (+ (* dx2 dx2) (+ (* dy2 dy2) (* dz2 dz2))))) 266 | (setf d1 (min d1 d2)) 267 | (setf (s~ d1 :xy) (min (s~ d1 :xy) (s~ d1 :wz))) 268 | (* (min (x d1) (y d1)) (/ 9.0 12.0)))))))) 269 | 270 | ;;---------------------------------------------------------------------- 271 | -------------------------------------------------------------------------------- /graphing/particle/particle-graph.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nineveh.graphing) 2 | 3 | ;; 4 | ;; This is a simple 3d graph that just uses instanced particles 5 | ;; as the points. Not the best for rapidly changing values but 6 | ;; could be handy for getting a general idea of what a function 7 | ;; is about. 8 | ;; 9 | 10 | ;;------------------------------------------------------------ 11 | ;; 12 | 13 | (defvar *pgraph-blend-params* 14 | (make-blending-params 15 | :mode-rgb :func-add 16 | :mode-alpha :func-add 17 | :source-rgb :one 18 | :destination-rgb :one 19 | :source-alpha :one 20 | :destination-alpha :one)) 21 | 22 | ;;------------------------------------------------------------ 23 | 24 | (defun-g pgraph-dot-frag ((uv :vec2) 25 | (color :vec4)) 26 | (let ((sdf-scale 25f0)) 27 | (mix 28 | (v! 0 0 0 0) 29 | color 30 | (nineveh.sdf.2d:mask-fill 31 | (nineveh.sdf.2d:circle (- (* uv 2 sdf-scale) (vec2 sdf-scale)) 32 | sdf-scale))))) 33 | 34 | ;;------------------------------------------------------------ 35 | ;; 36 | 37 | (defun pgraph-world->view (pos3 dir3) 38 | (m4:look-at (v! 0 1 0) pos3 (v3:+ pos3 dir3))) 39 | 40 | (defun pgraph-view->clip () 41 | (let ((vp (current-viewport))) 42 | (rtg-math.projection:perspective 43 | (float (viewport-resolution-x vp) 0f0) 44 | (float (viewport-resolution-y vp) 0f0) 45 | 1f0 46 | 5000f0 47 | 45f0))) 48 | 49 | (defun pgraph-process-pos (position-vec3) 50 | position-vec3) 51 | 52 | (defun pgraph-process-dir (direction-vec3) 53 | direction-vec3) 54 | 55 | ;;------------------------------------------------------------ 56 | 57 | (defclass pgraph-control-state () ()) 58 | 59 | ;;------------------------------------------------------------ 60 | ;; Universal 61 | 62 | (defgeneric args-for (kind)) 63 | (defgeneric instance-count-for (kind)) 64 | (defgeneric vert-transform-for (kind)) 65 | (defgeneric wrap-in-func-for (kind var body)) 66 | 67 | (defun key-args-for (kind) 68 | (loop 69 | :for (name init nil nil) :in (args-for kind) 70 | :collect (list name init))) 71 | 72 | (defun dispatch-args-for (kind) 73 | (loop 74 | :for (name nil type lisp-form) :in (args-for kind) 75 | :for kwd := (intern (string name) :keyword) 76 | :when type 77 | :append (list kwd lisp-form))) 78 | 79 | (defun uniform-args-for (kind) 80 | (loop 81 | :for (name nil type nil) :in (args-for kind) 82 | :when type 83 | :collect (list name type))) 84 | 85 | ;;------------------------------------------------------------ 86 | ;; Range Graph 87 | 88 | (defun-g range-vert-transform ((fn (function (:float) :vec3)) 89 | (vert g-pt) 90 | (world->view :mat4) 91 | (proj :mat4) 92 | (point-size :float) 93 | (point-color :vec4) 94 | ;; 95 | (min :float) 96 | (by :float)) 97 | (with-slots (position texture) vert 98 | (let* ((input (+ min (* by (float gl-instance-id)))) 99 | (func-result (funcall fn input)) 100 | (world-pos (vec4 func-result 1.0)) 101 | (view-pos (+ (* world->view world-pos) 102 | (vec4 (* position point-size) 0))) 103 | (clip-pos (* proj view-pos))) 104 | (values 105 | clip-pos 106 | texture 107 | point-color)))) 108 | 109 | (defmethod vert-transform-for ((kind (eql :range))) 110 | 'range-vert-transform) 111 | 112 | (defmethod args-for ((kind (eql :range))) 113 | '((min 0f0 :float (float min 0f0)) 114 | (max 100f0 nil (float by 0f0)) 115 | (by 1f0 :float (float by 0f0)))) 116 | 117 | (defmethod instance-count-for ((kind (eql :range))) 118 | `(floor (/ (- (float max 0f0) 119 | (float min 0f0)) 120 | (float by 0f0)))) 121 | 122 | (defmethod wrap-in-func-for ((kind (eql :range)) var body) 123 | `(graph-func ((,var :float)) (the :vec3 (progn ,@body)))) 124 | 125 | ;;------------------------------------------------------------ 126 | ;; Range-Color Graph 127 | 128 | (defun-g range-col-vert-transform ((fn (function (:float) (:vec3 :vec4))) 129 | (vert g-pt) 130 | (world->view :mat4) 131 | (proj :mat4) 132 | (point-size :float) 133 | (point-color :vec4) 134 | ;; 135 | (min :float) 136 | (by :float)) 137 | (with-slots (position texture) vert 138 | (let* ((input (+ min (* by (float gl-instance-id))))) 139 | (multiple-value-bind (func-pos func-col) (funcall fn input) 140 | (let* ((world-pos (vec4 func-pos 1.0)) 141 | (view-pos (+ (* world->view world-pos) 142 | (vec4 (* position point-size) 0))) 143 | (clip-pos (* proj view-pos))) 144 | (values 145 | clip-pos 146 | texture 147 | func-col)))))) 148 | 149 | ;; HEY! change this to 'range-vert-transform and watch it break, 150 | ;; somethign is funky in the compiler 151 | (defmethod vert-transform-for ((kind (eql :range-color))) 152 | 'range-col-vert-transform) 153 | 154 | (defmethod args-for ((kind (eql :range-color))) 155 | '((min 0f0 :float (float min 0f0)) 156 | (max 100f0 nil (float by 0f0)) 157 | (by 1f0 :float (float by 0f0)))) 158 | 159 | (defmethod instance-count-for ((kind (eql :range-color))) 160 | `(floor (/ (- (float max 0f0) 161 | (float min 0f0)) 162 | (float by 0f0)))) 163 | 164 | (defmethod wrap-in-func-for ((kind (eql :range-color)) var body) 165 | `(graph-func ((,var :float)) (the :vec3 (progn ,@body)))) 166 | 167 | ;;------------------------------------------------------------ 168 | ;; Height Graph 169 | 170 | (defun-g height-vert-transform ((fn (function (:vec2) :float)) 171 | (vert g-pt) 172 | (world->view :mat4) 173 | (proj :mat4) 174 | (point-size :float) 175 | (point-color :vec4) 176 | ;; 177 | (x-min :float) 178 | (x-max :float) 179 | (y-min :float) 180 | (y-max :float) 181 | (by :float) 182 | (spacing :float)) 183 | (with-slots (position texture) vert 184 | (let* ((id (float gl-instance-id)) 185 | (x-range (/ (- x-max x-min) by)) 186 | (y-range (/ (- y-max y-min) by)) 187 | (x (* (mod id x-range) by)) 188 | (y (* (/ id x-range) by)) 189 | (input (vec2 x y)) 190 | (pos2 (* input spacing point-size)) 191 | (func-result (funcall fn input)) 192 | (world-pos (v! (x pos2) func-result (y pos2) 1.0)) 193 | (view-pos (+ (* world->view world-pos) 194 | (vec4 (* position point-size) 0))) 195 | (clip-pos (* proj view-pos))) 196 | (values 197 | clip-pos 198 | texture 199 | point-color)))) 200 | 201 | (defmethod vert-transform-for ((kind (eql :height))) 202 | 'height-vert-transform) 203 | 204 | (defmethod args-for ((kind (eql :height))) 205 | '((x-min 0f0 :float (float x-min 0f0)) 206 | (x-max 100f0 :float (float x-max 0f0)) 207 | (y-min 0f0 :float (float y-min 0f0)) 208 | (y-max 100f0 :float (float y-max 0f0)) 209 | (by 1f0 :float (float by 0f0)) 210 | (spacing 1.3f0 :float (float spacing 0f0)))) 211 | 212 | (defmethod instance-count-for ((kind (eql :height))) 213 | `(floor (* (/ (- x-max x-min) by) 214 | (/ (- y-max y-min) by)))) 215 | 216 | (defmethod wrap-in-func-for ((kind (eql :height)) var body) 217 | `(graph-func ((,var :vec2)) (the :float (progn ,@body)))) 218 | 219 | ;;------------------------------------------------------------ 220 | ;; Height-Col Graph 221 | 222 | (defun-g height-col-vert-transform ((fn (function (:vec2) (:float :vec4))) 223 | (vert g-pt) 224 | (world->view :mat4) 225 | (proj :mat4) 226 | (point-size :float) 227 | (point-color :vec4) 228 | ;; 229 | (x-min :float) 230 | (x-max :float) 231 | (y-min :float) 232 | (y-max :float) 233 | (by :float) 234 | (spacing :float)) 235 | (with-slots (position texture) vert 236 | (let* ((id (float gl-instance-id)) 237 | (x-range (/ (- x-max x-min) by)) 238 | (y-range (/ (- y-max y-min) by)) 239 | (x (* (mod id x-range) by)) 240 | (y (* (/ id x-range) by)) 241 | (input (vec2 x y)) 242 | (pos2 (* input spacing point-size))) 243 | (multiple-value-bind (func-result func-col) 244 | (funcall fn input) 245 | (let* ((world-pos (v! (x pos2) func-result (y pos2) 1.0)) 246 | (view-pos (+ (* world->view world-pos) 247 | (vec4 (* position point-size) 0))) 248 | (clip-pos (* proj view-pos))) 249 | (values 250 | clip-pos 251 | texture 252 | func-col)))))) 253 | 254 | (defmethod vert-transform-for ((kind (eql :height-color))) 255 | 'height-col-vert-transform) 256 | 257 | (defmethod args-for ((kind (eql :height-color))) 258 | '((x-min 0f0 :float (float x-min 0f0)) 259 | (x-max 100f0 :float (float x-max 0f0)) 260 | (y-min 0f0 :float (float y-min 0f0)) 261 | (y-max 100f0 :float (float y-max 0f0)) 262 | (by 1f0 :float (float by 0f0)) 263 | (spacing 1.3f0 :float (float spacing 0f0)))) 264 | 265 | (defmethod instance-count-for ((kind (eql :height-color))) 266 | `(floor (* (/ (- x-max x-min) by) 267 | (/ (- y-max y-min) by)))) 268 | 269 | (defmethod wrap-in-func-for ((kind (eql :height-color)) var body) 270 | `(graph-func ((,var :vec2)) ,@body)) 271 | 272 | ;;------------------------------------------------------------ 273 | 274 | (defmacro define-pgraph (name 275 | (kind &rest options &key &allow-other-keys) 276 | (arg-name &rest uniforms) 277 | &body body) 278 | (declare (ignore options)) 279 | (assert (and (symbolp arg-name) (not (keywordp arg-name)))) 280 | (let* ((vert-name (intern (format nil "%~a-VERT" name) *package*)) 281 | (pline-name (intern (format nil "%~a-PIPELINE" name) *package*)) 282 | (uniform-names (mapcar #'first uniforms)) 283 | (uniform-keys (mapcar (lambda (x) (intern (string x) :keyword)) 284 | uniform-names)) 285 | (func (wrap-in-func-for kind arg-name body))) 286 | `(progn 287 | (defun-g ,vert-name ((vert g-pt) 288 | &uniform 289 | (world->view :mat4) 290 | (point-size :float) 291 | (proj :mat4) 292 | (point-color :vec4) 293 | ,@(uniform-args-for kind) 294 | ,@uniforms) 295 | (flet (,func) 296 | (,(vert-transform-for kind) 297 | #',(first func) vert world->view proj point-size point-color 298 | ,@(mapcar #'first (uniform-args-for kind))))) 299 | (defpipeline-g ,pline-name () 300 | :vertex (,vert-name g-pt) 301 | :fragment (pgraph-dot-frag :vec2 :vec4)) 302 | (defun ,name (position-vec3 303 | direction-vec3 304 | &key 305 | (point-color (vec4 0.7 0.7 0.8 0.0)) 306 | (point-size 1f0) 307 | ,@(key-args-for kind) 308 | ,@uniform-names) 309 | (let* ((pos (pgraph-process-pos position-vec3)) 310 | (dir (pgraph-process-dir direction-vec3))) 311 | (with-setf (depth-test-function) nil 312 | (with-blending *pgraph-blend-params* 313 | (with-instances ,(instance-count-for kind) 314 | (map-g #',pline-name (nineveh.internals:get-gpu-quad) 315 | :world->view (pgraph-world->view pos dir) 316 | :proj (pgraph-view->clip) 317 | :point-color point-color 318 | :point-size (float point-size 0f0) 319 | ,@(dispatch-args-for kind) 320 | ,@(mapcan #'list uniform-keys uniform-names)))))))))) 321 | 322 | ;;------------------------------------------------------------ 323 | --------------------------------------------------------------------------------