Skip to content

Instantly share code, notes, and snippets.

@jackfirth
Last active May 9, 2021 08:14
Show Gist options
  • Save jackfirth/d14772a69babf472a6b1211ded46c3eb to your computer and use it in GitHub Desktop.
Save jackfirth/d14772a69babf472a6b1211ded46c3eb to your computer and use it in GitHub Desktop.
#lang racket/base
(provide sdfn-register-id scalar-sdfn-register-id vec3-sdfn-register-id (struct-out sdfn-register))
(require syntax/parse)
(struct sdfn-register (size offset initial-values) #:transparent)
(define-syntax-class sdfn-register-id
#:description "an SDFN register"
#:attributes (register size offset [initial-value 1])
(pattern id
#:declare id (static sdfn-register? "a static sdfn-register? value")
#:attr register (attribute id.value)
#:attr size (sdfn-register-size (attribute register))
#:attr offset (sdfn-register-offset (attribute register))
#:with (initial-value ...)
(for/list ([x (in-list (sdfn-register-initial-values (attribute register)))])
#`#,x)))
(define-syntax-class scalar-sdfn-register-id
#:description "a scalar SDFN register"
#:attributes (register size offset [initial-value 1])
(pattern :sdfn-register-id
#:fail-unless (equal? (attribute size) 1)
(format "scalar registers must have a size of one, but this register has size ~a"
(attribute size))))
(define-syntax-class vec3-sdfn-register-id
#:description "a vec3 SDFN register"
#:attributes (register size offset [initial-value 1])
(pattern :sdfn-register-id
#:fail-unless (equal? (attribute size) 3)
(format "vec3 registers must have a size of 3, but this register has size ~a"
(attribute size))))
#lang racket
(require (for-syntax racket/list
racket/sequence
racket/syntax
syntax/parse
"racketized-sdfn-base.rkt")
racket/stxparam
syntax/parse/define)
(require racket/format)
(require racket/flonum)
(provide sdfn)
(define-syntax reg #false)
(begin-for-syntax
(define-syntax-class sdfn-register-definition
#:description "an SDFN register definition"
#:attributes (size name [fill 1])
#:literals (reg)
(pattern (reg size:nat name:id)
#:with (fill ...) (make-list (syntax-e #'size) #'0.0))
(pattern (reg size:nat name:id fill:number ...+)
#:do [(define fill-count (length (syntax->list #'(fill ...))))]
#:fail-when (< (syntax-e #'size) fill-count)
(format "not enough fill values for register, expected ~a but got ~a"
(syntax-e #'size) fill-count)
#:fail-when (> (syntax-e #'size) fill-count)
(format "too many fill values for register, expected ~a but got ~a"
(syntax-e #'size) fill-count)))
(define-splicing-syntax-class sdfn-register-definition-sequence
#:attributes (syntax-definitions initial-register-vector last-index)
(pattern (~seq reg-def:sdfn-register-definition ...)
#:with (last-index (offset ...))
(for/fold ([current-offset 0]
[previous-offsets '()]
#:result (list #`#,(sub1 current-offset) (reverse previous-offsets)))
([reg-size (in-syntax #'(reg-def.size ...))])
(define next-offset (+ current-offset (syntax-e reg-size)))
(values next-offset (cons #`#,current-offset previous-offsets)))
#:with syntax-definitions
#'(begin
(define-syntax reg-def.name (sdfn-register reg-def.size offset (list reg-def.fill ...)))
...)
#:with initial-register-vector #'(flvector reg-def.fill ... ...))))
(define-syntax-parameter sdfn-register-vector
(λ (stx) (raise-syntax-error #false "cannot be used outside an sdfn form" stx)))
(define-syntax-parse-rule (reg-set! reg:sdfn-register-id lane:nat new-value:expr)
#:fail-unless (< (syntax-e #'lane) (attribute reg.size))
(format "register lane ~a out of bounds for register of size ~a"
(syntax-e #'lane) (attribute reg.size))
#:with loc #`#,(+ (attribute reg.offset) (syntax-e #'lane))
(flvector-set! sdfn-register-vector loc new-value))
(define-syntax-parse-rule (reg-get reg:sdfn-register-id lane:nat)
#:fail-unless (< (syntax-e #'lane) (attribute reg.size))
(format "register lane ~a out of bounds for register of size ~a"
(syntax-e #'lane) (attribute reg.size))
#:with loc #`#,(+ (attribute reg.offset) (syntax-e #'lane))
(flvector-ref sdfn-register-vector loc))
(define-syntax-parse-rule
(sdfn-binary-op op-function:id out:sdfn-register-id lhs:sdfn-register-id rhs:sdfn-register-id)
#:with (lane ...)
(for/list ([i (in-range 0 (min (attribute out.size) (attribute lhs.size) (attribute rhs.size)))])
#`#,i)
(begin
(reg-set! out lane (op-function (reg-get lhs lane) (reg-get rhs lane)))
...))
(define-syntax-parse-rule (define-sdfn-binary-op name:id op-function:id)
(define-syntax-parse-rule (name out:sdfn-register-id lhs:sdfn-register-id rhs:sdfn-register-id)
(sdfn-binary-op op-function out lhs rhs)))
(define-sdfn-binary-op add fl+)
(define-sdfn-binary-op sub fl-)
(define-sdfn-binary-op mul fl*)
(define-sdfn-binary-op div fl/)
(define-sdfn-binary-op min flmin)
(define-sdfn-binary-op max flmax)
(define-syntax-parse-rule (sqrt out:sdfn-register-id vec:sdfn-register-id)
#:with (lane ...)
(for/list ([i (in-range 0 (min (attribute out.size) (attribute vec.size)))])
#`#,i)
(begin
(reg-set! out lane (flsqrt (reg-get vec lane)))
...))
(define-syntax-parse-rule (dot out:sdfn-register-id lhs:sdfn-register-id rhs:sdfn-register-id)
#:fail-unless (equal? (attribute out.size) 1)
"expected a scalar output for dot operator"
#:with (lane ...)
(for/list ([i (in-range 0 (min (attribute lhs.size) (attribute rhs.size)))])
#`#,i)
(reg-set! out 0 (fl+ (fl* (reg-get lhs lane) (reg-get rhs-lane)) ...)))
(define-syntax-parse-rule (len out:sdfn-register-id vec:sdfn-register-id)
#:fail-unless (equal? (attribute out.size) 1)
"expected a scalar output for len operator"
#:with (lane ...)
(for/list ([i (in-range 0 (attribute vec.size))])
#`#,i)
(reg-set! out 0 (flsqrt (fl+ (fl* (reg-get vec lane) (reg-get vec lane)) ...))))
(define-syntax-parse-rule
(sd-cut out:scalar-sdfn-register-id lhs:scalar-sdfn-register-id rhs:scalar-sdfn-register-id)
(reg-set! out 0 (flmax (reg-get lhs 0) (fl* -1. (reg-get rhs 0)))))
(define-syntax-parse-rule
(sd-sphere out:scalar-sdfn-register-id vec:vec3-sdfn-register-id rad:scalar-sdfn-register-id)
#:with (lane ...)
(for/list ([i (in-range 0 (attribute vec.size))])
#`#,i)
(reg-set!
out 0 (fl- (flsqrt (fl+ (fl* (reg-get vec lane) (reg-get vec lane)) ...)) (reg-get rad 0))))
(define-syntax-parse-rule (sdfn registers:sdfn-register-definition-sequence command ...)
(let ([register-vec registers.initial-register-vector])
(lambda (x y z)
(flvector-set! register-vec 0 x)
(flvector-set! register-vec 1 y)
(flvector-set! register-vec 2 z)
registers.syntax-definitions
(syntax-parameterize ([sdfn-register-vector (make-rename-transformer #'register-vec)])
command ...)
(flvector-ref register-vec registers.last-index))))
(define sd
(sdfn (reg 3 input)
(reg 3 offset-2 -50. 0. 50.)
(reg 3 point)
(reg 1 radius-1 200.)
(reg 1 radius-2 150.)
(reg 1 sphere-1)
(reg 1 sphere-2)
(reg 1 out)
(sd-sphere sphere-1 input radius-1)
(sub point input offset-2)
(sd-sphere sphere-2 point radius-2)
(sd-cut out sphere-1 sphere-2)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment