racketized-sdfn-base.rkt

#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))))

racketized-sdfn.rkt

#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)))