path: root/chickadee/graphics/seagull.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(define-module (chickadee graphics seagull)
  #:use-module (chickadee graphics seagull cps)
  #:use-module (chickadee graphics seagull glsl)
  #:use-module (chickadee graphics seagull pass-expand)
  #:use-module (chickadee graphics seagull pass-infer)
  #:use-module (chickadee graphics seagull pass-linearize)
  #:use-module (chickadee graphics seagull syntax)
  #:use-module (chickadee graphics seagull types)
  #:use-module (chickadee graphics seagull utils)
  #:use-module (ice-9 pretty-print)
  #:export (compile-seagull
            compile-vertex
            compile-fragment)
  #:re-export ($gl))

(define (pretty-pk x)
  (pretty-print x)
  x)

(define (pretty-pk-cps x)
  (pretty-print (graph->sexp x))
  x)

(define (compile-seagull exp stage)
  (define-values (graph types subs)
    (infer
     (pretty-pk-cps
      (linearize
       (pretty-pk
        (expand exp stage))))))
  ;;(unbox-substitutions subs)
  (emit-glsl graph))

(define (compile-vertex exp)
  (compile-seagull exp stage:vertex))

(define (compile-fragment exp)
  (compile-seagull exp stage:fragment))

;; ILs:
;; - Base
;; - Untyped CPS
;; - Typed CPS

;; Passes:
;; - Expansion
;; - Partial evaluation
;; - CPS
;; - Type inference
;; - GLSL emission

;; Importable things:
;; - floats
;; - ints
;; - shader types
;; - shader functions




;; vec3 toneMap(vec3 color) {
;;   return color / (color + vec3(1.0));
;; }
'(define tone-map
   (seagull
    (lambda (color)
      (/ color (+ color (vec3 1.0))))))
'(define-seagull (tone-map color)
   (/ color (+ color (vec3 1.0))))

'(define-seagull (tone-map/red color)
   #:import (tone-map)
   (vec3 (-> (tone-map color) x)))

'(define-seagull pi 3.14159)

'(define-seagull sprite-vertex
   (vertex-shader
    #:in ((position vec2)
          (tex vec2)
          (tint vec2))
    #:uniform ((mvp mat4))
    #:out ((vertex:position vec4)
           (frag-text vec2)
           (frag-tint vec4))
    #:import (tone-map)
    (values
     (vertex:position (* mvp (vec4 position 0.0 1.0)))
     (frag-tex tex)
     (frag-tint (tone-map tint)))))

;; (define-record-type <seagull-syntax>
;;   (make-seagull-syntax source exp)
;;   seagull-syntax?
;;   (source seagull-syntax-source)
;;   (exp seagull-syntax-expression))

;; (define (assert-seagull-syntax obj)
;;   (unless (seagull-syntax? obj)
;;     (throw 'not-seagull-syntax obj)))

;; (define-record-type <seagull-constant>
;;   (make-seagull-constant value)
;;   seagull-constant?
;;   (value seagull-constant-value))

;; (define (seagull-constant x)
;;   (unless (constant? x)
;;     (throw 'not-a-constant x))
;;   (make-seagull-constant x))

;; (define-record-type <seagull-reference>
;;   (make-seagull-reference name)
;;   seagull-reference?
;;   (name seagull-reference-name))

;; (define (seagull-reference name)
;;   (unless (symbol? name)
;;     (throw 'invalid-reference name))
;;   (make-seagull-reference name))

;; (define-record-type <seagull-primcall>
;;   (make-seagull-primcall name args)
;;   seagull-primcall?
;;   (name seagull-primcall-name)
;;   (args seagull-primcall-args))

;; (define (seagull-primcall name . args)
;;   (for-each assert-seagull-syntax args)
;;   (make-seagull-primcall name args))

;; (define-record-type <seagull-if>
;;   (make-seagull-if predicate consequent alternate)
;;   seagull-if?
;;   (predicate seagull-if-predicate)
;;   (consequent seagull-if-consequent)
;;   (alternate seagull-if-alternate))

;; (define (seagull-if predicate consequent alternate)
;;   (assert-seagull-syntax predicate)
;;   (assert-seagull-syntax consequent)
;;   (assert-seagull-syntax alternate)
;;   (make-seagull-if predicate consequent alternate))

;; ;; ((lambda (x)
;; ;;    (syntax-case x ()
;; ;;      ((_ exp)
;; ;;       (with-syntax ((src (datum->syntax x (syntax-sourcev #'exp))))
;; ;;         #'(make-seagull-syntax src exp)))))
;; ;;  (call-with-input-string "(foo 1)" read-syntax))

;; (define-syntax seagull-syntax
;;   (lambda (x)
;;     (syntax-case x ()
;;       ((_ exp)
;;        (with-syntax ((src (datum->syntax x (syntax-sourcev #'exp))))
;;          #'(make-seagull-syntax src exp))))))

;; (define (seagull-identity x)
;;   (assert-seagull-syntax x)
;;   x)

;; (define-syntax-rule (sgl:const x)
;;   (seagull-syntax (seagull-constant x)))

;; (define-syntax-rule (sgl:ref name)
;;   (seagull-syntax (seagull-reference 'name)))

;; (define-syntax-rule (sgl:if predicate consequent alternate)
;;   (seagull-syntax (seagull-if predicate consequent alternate)))

;; (define-syntax sgl:cond
;;   (syntax-rules (else)
;;     ((_ (else exp))
;;      (seagull-identity exp))
;;     ((_ (pred body) rest ...)
;;      (sgl:if pred body (sgl:cond rest ...)))))

;; (define-syntax sgl:+
;;   (syntax-rules ()
;;     ((_)
;;      (sgl:const 0))
;;     ((_ x)
;;      (seagull-identity x))
;;     ((_ x rest ...)
;;      (seagull-syntax (seagull-primcall '+ x (sgl:+ rest ...))))))

;; (sgl:+)
;; (sgl:+ (sgl:const 1))
;; (sgl:+ (sgl:const 1) (sgl:ref x))
;; (sgl:if (sgl:const #t)
;;         (sgl:+ (sgl:const 1) (sgl:const 2) (sgl:const 3))
;;         (sgl:+ (sgl:const 4) (sgl:const 5) (sgl:const 6)))
;; (sgl:cond
;;  ((sgl:const #t)
;;   (sgl:+ (sgl:const 1) (sgl:const 2) (sgl:const 3)))
;;  (else
;;   (sgl:+ (sgl:const 4) (sgl:const 5) (sgl:const 6))))

;; (define (my+ a b)
;;   `(sum ,(+ a b)))

;; (define-syntax weird+
;;   (lambda (x)
;;     (syntax-case x ()
;;       ((_ exp)
;;        (with-syntax ((+ (datum->syntax #'exp '+)))
;;          #'(let ((+ sgl:+))
;;              exp))))))

;; (define (s+ x y) `(primcall + ,x ,y))
;; (define (s* x y) `(primcall * ,x ,y))
;; (define-syntax seagull
;;   (lambda (x)
;;     (syntax-case x ()
;;       ((_ exp)
;;        (with-syntax ((+ (datum->syntax x '+))
;;                      (* (datum->syntax x '*)))
;;          #'(let ((+ s+) (* s*)) exp))))))

;; (seagull (+ (* 2 2) (* 3 3)))

;; (define-syntax $gl-expand
;;   (lambda (x)
;;     (syntax-case x ()
;;       ((_ (f y z))
;;        (with-syntax ((+ (datum->syntax x 'sgl:+)))
;;          #'(+ y z))))))

;; ($gl-expand (+ 1 2))

;; ;; Annotate seagull expressions with source information, producing
;; ;; seagull-specific syntax objects that can't be confused with scheme
;; ;; syntax objects.
;; (define-syntax $gl
;;   (lambda (x)
;;     (syntax-case x ()
;;       ((_ exp)
;;        (with-syntax ((src (datum->syntax x (syntax-sourcev #'exp))))
;;          #'(seagull-syntax src ($gl-recur exp)))))))

;; ;; Helper macro to annotate nested expressions.
;; (define-syntax $gl-recur
;;   (syntax-rules ()
;;     ((_ (item ...))
;;      (list ($gl item) ...))
;;     ((_ atom)
;;      atom)))