├── qlfile ├── .gitignore ├── images └── webgl-demo.png ├── qlfile.lock ├── load.lisp ├── README.md ├── js.lisp ├── mat.lisp ├── id-map.lisp ├── websock.lisp ├── examples.lisp └── gl.lisp /qlfile: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | .qlot/ 3 | -------------------------------------------------------------------------------- /images/webgl-demo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/byulparan/websocket-demo/HEAD/images/webgl-demo.png -------------------------------------------------------------------------------- /qlfile.lock: -------------------------------------------------------------------------------- 1 | ("quicklisp" . 2 | (:class qlot/source/dist:source-dist 3 | :initargs (:distribution "http://beta.quicklisp.org/dist/quicklisp.txt" :%version :latest) 4 | :version "2023-02-15")) 5 | -------------------------------------------------------------------------------- /load.lisp: -------------------------------------------------------------------------------- 1 | 2 | (ql:quickload :parenscript) 3 | (ql:quickload :clws) 4 | (ql:quickload :parse-number) 5 | (ql:quickload :bordeaux-threads) 6 | (ql:quickload :bt-semaphore) 7 | (ql:quickload :hunchentoot) 8 | (ql:quickload :cl-who) 9 | 10 | (load "js.lisp") 11 | (load "gl.lisp") 12 | (load "mat.lisp") 13 | (load "websock.lisp") 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # WebGL Demo in Common Lisp 2 | 3 | Also it demonstrates how to send pieces of JS code to the browser via Websocket. 4 | 5 | This is just demo code shown in [my websocket/webgl video](http://www.youtube.com/watch?v=aKYzfew1pnE) by Sungmin Park. 6 | 7 | It's very experimental level. 8 | 9 | ![](images/webgl-demo.png) 10 | 11 | #### Requirements 12 | - [Quicklisp](http://www.quicklisp.org) 13 | - Common Lisp Implementations 14 | + [ClozureCL](http://www.clozure.com/clozurecl.html) 15 | + [SBCL](http://www.sbcl.org) 16 | 17 | #### Usage 18 | 19 | Start REPL and do: 20 | 21 | ``` 22 | (load "load.lisp") 23 | ``` 24 | 25 | Then open "examples.lisp" and eval forms upto this line: 26 | 27 | ``` 28 | ;;; open your webbrowser. then go to 127.0.0.1:8080/ws-repl.html 29 | ``` 30 | 31 | Open the page in the browser. It will connect back to the Lisp via a websocket and will wait for the commands. 32 | 33 | Continue evaluating forms one by one and on the final form you should see an animation. Now you can play with 34 | DRAW-SCENE function. For example, try to change a number of loops in DOTIMES form. 35 | -------------------------------------------------------------------------------- /js.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:js 3 | (:use #:cl #:ps) 4 | (:export #:define-ps-macro 5 | #:define-jsfun 6 | ;; dom 7 | #:-> 8 | #:by-id 9 | #:by-tagname 10 | #:create-element 11 | #:create-text-node)) 12 | 13 | 14 | (in-package #:js) 15 | 16 | (defmacro define-ps-macro (name arg &body body) 17 | `(progn 18 | (defmacro ,name ,arg 19 | ,@body) 20 | (import-macros-from-lisp ',name) 21 | (export ',name))) 22 | 23 | (defmacro define-jsfun (name args &body body) 24 | (let ((table-name (intern "*JS-TABLE*" *package*))) 25 | `(progn 26 | (defvar ,table-name nil) 27 | (setf (getf ,table-name ',name) 28 | (quote (setf ,name (lambda ,args ,@body)))) 29 | ',name))) 30 | 31 | (defpsmacro define-jsfun (name args &body body) 32 | `(progn (setf ,name (lambda ,args ,@body)) 33 | "undefined")) 34 | 35 | 36 | (defpsmacro -> (&body chain) 37 | `(chain ,@chain)) 38 | 39 | (defpsmacro by-id (id) 40 | `(-> document (get-element-by-id ,id))) 41 | 42 | (defpsmacro by-tagname (tagname) 43 | `(-> document (get-elements-by-tag-name ,tagname))) 44 | 45 | (defpsmacro create-element (tagname) 46 | `(-> document (create-element ,tagname))) 47 | 48 | (defpsmacro create-text-node (text) 49 | `(-> document (create-text-node ,text))) 50 | -------------------------------------------------------------------------------- /mat.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:mat 3 | (:use #:cl #:ps) 4 | (:shadow #:identity) 5 | (:import-from :gl :define-ps-macro) 6 | (:export #:install-matrix 7 | #:mv-push-matrix 8 | #:mv-pop-matrix 9 | #:set-matrix-uniforms)) 10 | 11 | (in-package :mat) 12 | 13 | (define-ps-macro create-mat4 () 14 | `(chain gl-matrix mat4 (create))) 15 | 16 | (define-ps-macro create-mat3 () 17 | `(chain gl-matrix mat3 (create))) 18 | 19 | (define-ps-macro set-mat4 (src-matrix dst-matrix) 20 | `(chain gl-matrix mat4 (set ,src-matrix ,dst-matrix ))) 21 | 22 | (define-ps-macro identity (dest) 23 | `(chain gl-matrix mat4 (identity ,dest))) 24 | 25 | (define-ps-macro perspective (fovy aspect near far dest) 26 | `(chain gl-matrix mat4 (perspective ,fovy ,aspect ,near ,far ,dest))) 27 | 28 | (define-ps-macro ortho (left right bottom top near far dest) 29 | `(chain gl-matrix mat4 (ortho ,left ,right ,bottom ,top ,near ,far ,dest))) 30 | 31 | (define-ps-macro rotate (dest angle axis) 32 | `(chain gl-matrix mat4 (rotate ,dest ,dest ,angle ,axis ))) 33 | 34 | (define-ps-macro translate (dest vec) 35 | `(chain gl-matrix mat4 (translate ,dest ,dest ,vec))) 36 | 37 | (define-ps-macro scale (dest vec) 38 | `(chain gl-matrix mat4 (scale ,dest ,vec))) 39 | 40 | (define-ps-macro to-inverse-mat3 (src-matrix dst-matrix) 41 | `(chain gl-matrix mat4 (to-inverse-mat3 ,src-matrix ,dst-matrix))) 42 | 43 | (define-ps-macro transpose (matrix) 44 | `(chain gl-matrix mat3 (transpose ,matrix))) 45 | 46 | 47 | 48 | (defpsmacro install-matrix (shader-program p-matrix mv-matrix) 49 | `(let ((p-matrix-location (gl:get-uniform-location ,shader-program "uPMatrix")) 50 | (mv-matrix-location (gl:get-uniform-location ,shader-program "uMVMatrix")) 51 | (mv-matrix-stack (list))) 52 | (setf ,p-matrix (create-mat4)) 53 | (setf ,mv-matrix (create-mat4)) 54 | (js:define-jsfun mv-push-matrix () 55 | (let* ((copy (create-mat4))) 56 | (set-mat4 ,mv-matrix copy) 57 | (chain mv-matrix-stack (push copy)))) 58 | (js:define-jsfun mv-pop-matrix () 59 | (setf ,mv-matrix (chain mv-matrix-stack (pop)))) 60 | (js:define-jsfun set-matrix-uniforms () 61 | (gl:uniform-matrix-4fv p-matrix-location f ,p-matrix) 62 | (gl:uniform-matrix-4fv mv-matrix-location f ,mv-matrix)))) 63 | 64 | ;;; dummy 65 | (defun install-matrix (shader-program p-matrix mv-matrix) 66 | (declare (ignore shader-program p-matrix mv-matrix))) 67 | 68 | (defun mv-push-matrix () 69 | ()) 70 | 71 | (defun mv-pop-matrix () 72 | ()) 73 | 74 | (defun set-matrix-uniforms () 75 | ()) 76 | -------------------------------------------------------------------------------- /id-map.lisp: -------------------------------------------------------------------------------- 1 | ;;; This id-map implentation code all from ClozureCL. 2 | ;;; I want use it in SBCL....so just I was copy.(1:1) 3 | ;;; I use id-map for sync to scsynth <---> lisp(#'sync). 4 | 5 | (defpackage #:id-map 6 | (:use #:cl) 7 | (:export #:make-id-map 8 | #:assign-id-map-id 9 | #:id-map-free-object)) 10 | 11 | (in-package #:id-map) 12 | 13 | ;;; ---id map ------------------------------------ 14 | (defstruct id-map 15 | (vector (make-array 1 :initial-element nil)) 16 | (free 0) 17 | (lock (bt:make-lock))) 18 | 19 | (defun id-map-grow (id-map) 20 | (let* ((old-vector (id-map-vector id-map)) 21 | (old-size (length old-vector)) 22 | (new-size (+ old-size old-size)) 23 | (new-vector (make-array new-size))) 24 | (declare (fixnum old-size new-size)) 25 | (dotimes (i old-size) 26 | (setf (svref new-vector i) (svref old-vector i))) 27 | (let* ((limit (1- new-size))) 28 | (declare (fixnum limit)) 29 | (do* ((i old-size (1+ i))) 30 | ((= i limit) (setf (svref new-vector i) nil)) 31 | (declare (fixnum i)) 32 | (setf (svref new-vector i) (the fixnum (1+ i))))) 33 | (setf (id-map-vector id-map) new-vector 34 | (id-map-free id-map) old-size))) 35 | 36 | (defun assign-id-map-id (id-map object) 37 | (if (or (null object) (typep object 'fixnum)) (error "object must not fixnum or NIL")) 38 | (bt:with-lock-held ((id-map-lock id-map)) 39 | (let* ((free (or (id-map-free id-map) (id-map-grow id-map))) 40 | (vector (id-map-vector id-map)) 41 | (newfree (svref vector free))) 42 | (setf (id-map-free id-map) newfree 43 | (svref vector free) object) 44 | free))) 45 | 46 | (defun id-map-object (id-map id) 47 | (let* ((object (bt:with-lock-held ((id-map-lock id-map)) 48 | (svref (id-map-vector id-map) id)))) 49 | (if (or (null object) (typep object 'fixnum)) 50 | (error "invalid index ~d for ~s" id id-map) 51 | object))) 52 | 53 | (defun id-map-free-object (id-map id) 54 | (bt:with-lock-held ((id-map-lock id-map)) 55 | (let* ((vector (id-map-vector id-map)) 56 | (object (svref vector id))) 57 | (if (or (null object) (typep object 'fixnum)) 58 | (error "invalid index ~d for ~s" id id-map)) 59 | (setf (svref vector id) (id-map-free id-map) 60 | (id-map-free id-map) id) 61 | object))) 62 | 63 | (defun id-map-modify-object (id-map id old-value new-value) 64 | (bt:with-lock-held ((id-map-lock id-map)) 65 | (let* ((vector (id-map-vector id-map)) 66 | (object (svref vector id))) 67 | (if (or (null object) (typep object 'fixnum)) 68 | (error "invalid index ~d for ~s" id id-map)) 69 | (if (eq object old-value) 70 | (setf (svref vector id) new-value))))) 71 | -------------------------------------------------------------------------------- /websock.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:websock 3 | (:use #:cl #:ps) 4 | (:export #:install-websock 5 | #:start-websocket-server 6 | #:in-ws-repl)) 7 | 8 | (in-package #:websock) 9 | 10 | #+sbcl (load "id-map.lisp") 11 | #+sbcl (use-package :id-map) 12 | 13 | #+ccl (import '(ccl::make-id-map ccl::assign-id-map-id ccl::id-map-free-object)) 14 | 15 | (defvar *client* nil) 16 | (defvar *id-map* nil) 17 | 18 | (defclass message-box () 19 | ((result :initform nil :accessor result) 20 | (errorp :initform nil :accessor errorp) 21 | (semaphore :initarg :semaphore :reader semaphore))) 22 | 23 | (defclass repl-resource (ws:ws-resource) 24 | ()) 25 | 26 | (defmethod ws:resource-client-connected ((res repl-resource) client) 27 | (unless *client* 28 | (setf *client* client) 29 | (format t "~&got connection on repl~%")) 30 | t) 31 | 32 | (defmethod ws:resource-client-disconnected ((res repl-resource) client) 33 | (format t "~&disconnected resouce ~a~%" client) 34 | (setf *client* nil)) 35 | 36 | (defmethod ws:resource-received-text ((res repl-resource) client message) 37 | (declare (ignore client)) 38 | (multiple-value-bind (identifiersi offset) 39 | (read-from-string message) 40 | (destructuring-bind (id numberp errorp) 41 | identifiersi 42 | (let ((result (subseq message offset)) 43 | (object (id-map-free-object *id-map* id))) 44 | (when numberp (setf result (parse-number:parse-number result))) 45 | (setf (errorp object) errorp) 46 | (setf (result object) result) 47 | (bt-sem:signal-semaphore (semaphore object)))))) 48 | 49 | (defpsmacro install-websock (port) 50 | `(progn 51 | (defvar socket (new (-web-socket (lisp (format nil "ws://127.0.0.1:~a/repl" ,port))))) 52 | (setf (chain socket onopen) 53 | (lambda () (chain console (log "openning connect to websocket")))) 54 | (setf (chain socket onmessage) 55 | (lambda (msg) 56 | (chain console (log "receive message")) 57 | (let* ((json (eval (@ msg data))) 58 | (id (@ json id)) 59 | (result nil) 60 | (numberp nil) 61 | (errorp "NIL")) 62 | (try (progn (setf result (eval (@ json task)) 63 | numberp (if (string= (typeof result) "number") "T" "NIL"))) 64 | (:catch (error) 65 | (setf result error 66 | numberp "NIL" 67 | errorp "T")) 68 | (:finally (chain socket (send (+ "(" id " " numberp " " errorp ")" result)))))))))) 69 | 70 | (defun start-websocket-server (port) 71 | (setf *id-map* (make-id-map)) 72 | (bt:make-thread (lambda () (ws:run-server port)) :name "websocket server") 73 | (ws:register-global-resource "/repl" 74 | (make-instance 'repl-resource) 75 | (ws:origin-prefix "http://127.0.0.1" "http://localhost")) 76 | (bt:make-thread 77 | (lambda () 78 | (ws:run-resource-listener (ws:find-global-resource "/repl"))) 79 | :name "resource listener for /repl")) 80 | 81 | 82 | 83 | (define-condition websocket-repl-error (error) 84 | ((error-report :initarg :error-report :reader error-report)) 85 | (:report (lambda (condition stream) 86 | (format stream "~a" (error-report condition))))) 87 | 88 | 89 | (defun call-in-ws-repl (thunk) 90 | (declare (optimize (debug 3) (safety 3))) 91 | (let* ((object (make-instance 'message-box :semaphore (bt-sem:make-semaphore))) 92 | (id (assign-id-map-id *id-map* object))) 93 | (ws:write-to-client-text 94 | *client* 95 | (ps (setf x 96 | (create :id (lisp id) :task (lisp thunk))))) 97 | (bt-sem:wait-on-semaphore (semaphore object)) 98 | (if (errorp object) 99 | (error 'websocket-repl-error :error-report (result object)) 100 | (result object)))) 101 | 102 | 103 | (defmacro in-ws-repl (&body body) 104 | `(call-in-ws-repl (ps ,@body))) 105 | 106 | 107 | (defmacro in-ws-repl-orig (&body body) 108 | `(let* ((object (make-instance 'message-box :semaphore (bt-sem:make-semaphore))) 109 | (id (assign-id-map-id *id-map* object))) 110 | (ws:write-to-client-text 111 | *client* 112 | (ps (setf x 113 | (create :id (lisp id) :task (lisp (ps ,@body)))))) 114 | (bt-sem:wait-on-semaphore (semaphore object)) 115 | (if (errorp object) (error 'websocket-repl-error :error-report (result object)) 116 | (result object)))) 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | -------------------------------------------------------------------------------- /examples.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:web-repl 3 | (:use #:cl #:websock #:js #:ps)) 4 | 5 | (in-package #:web-repl) 6 | 7 | (defparameter *server* (make-instance 'hunchentoot:easy-acceptor :port 8080)) 8 | (hunchentoot:start *server*) 9 | 10 | (start-websocket-server 9999) ;start-websocket server 11 | 12 | 13 | (hunchentoot:define-easy-handler (ws-repl :uri "/ws-repl.html") nil 14 | (who:with-html-output-to-string (html nil :prologue "") 15 | (:html 16 | (:head 17 | (:title "web-repl demo")) 18 | (:body 19 | (:script (ps:ps-to-stream html (install-websock 9999))))))) 20 | 21 | ;;; open your webbrowser. then go to 127.0.0.1:8080/ws-repl.html 22 | 23 | (in-ws-repl 24 | (alert "hello world")) 25 | 26 | (in-ws-repl 27 | (+ 10 20 30 40)) 28 | 29 | (in-ws-repl 30 | (define-jsfun foo (a b c) 31 | (+ a b c))) 32 | 33 | (in-ws-repl 34 | (foo 10 20 30)) 35 | 36 | (in-ws-repl 37 | (let ((canvas (create-element "canvas"))) 38 | (setf (@ canvas style background) "black") 39 | (-> canvas (set-attribute "id" "gl-canvas")) 40 | (-> canvas (set-attribute "width" (@ window inner-width))) 41 | (-> canvas (set-attribute "height" (@ window inner-height))) 42 | (-> (@ document body) (append-child canvas)))) 43 | 44 | (in-ws-repl 45 | (let ((script (create-element "script"))) 46 | (setf (-> script src) "https://cdnjs.cloudflare.com/ajax/libs/gl-matrix/3.4.2/gl-matrix.js") 47 | (-> document body (append-child script)))) 48 | 49 | 50 | (defparameter *vertex-shader* " 51 | attribute vec3 aVertexPosition; 52 | attribute vec3 aVertexColor; 53 | uniform mat4 uPMatrix; 54 | uniform mat4 uMVMatrix; 55 | varying highp vec4 uColor; 56 | void main () { 57 | gl_Position = uPMatrix * uMVMatrix * vec4(aVertexPosition, 1.0); 58 | uColor = vec4(aVertexColor, 1.0); 59 | }") 60 | 61 | (defparameter *fragment-shader* " 62 | varying highp vec4 uColor; 63 | void main () { 64 | gl_FragColor = uColor; 65 | }") 66 | 67 | 68 | ;;; setup for webgl 69 | ;; This fails on missing mat4 70 | (in-ws-repl 71 | (gl:with-gl-canvas (canvas "gl-canvas") 72 | (setf shader-program (gl:init-shader (lisp *vertex-shader*) 73 | (lisp *fragment-shader*))) 74 | (gl:use-program shader-program) 75 | (mat:install-matrix shader-program p-matrix mv-matrix))) 76 | 77 | (in-ws-repl 78 | (setf (@ shader-program vertex-pos-attrib) (gl:get-attrib-location shader-program "aVertexPosition") 79 | (@ shader-program vertex-color-attrib) (gl:get-attrib-location shader-program "aVertexColor")) 80 | (gl:enable-vertex-attrib-array (@ shader-program vertex-pos-attrib)) 81 | (gl:enable-vertex-attrib-array (@ shader-program vertex-color-attrib)) 82 | (setf vertex-position-buffer (gl:create-buffer) 83 | vertex-color-buffer (gl:create-buffer) 84 | vertex-indicies-buffer (gl:create-buffer))) 85 | 86 | ;;; init buffers 87 | (in-ws-repl 88 | (gl:bind-buffer :array-buffer vertex-position-buffer) 89 | (gl:buffer-data :array-buffer (new (-float-32-array (list -.5 -.5 0 90 | .5 -.5 0 91 | .5 .5 0 92 | -.5 .5 0))) :static-draw) 93 | (gl:bind-buffer :array-buffer vertex-color-buffer) 94 | (gl:buffer-data :array-buffer (new (-float-32-array (list (random) (random) (random) 95 | (random) (random) (random) 96 | (random) (random) (random) 97 | (random) (random) (random)))) :static-draw) 98 | (gl:bind-buffer :element-array-buffer vertex-indicies-buffer) 99 | (gl:buffer-data :element-array-buffer (new (-uint-16-array (list 0 1 3 100 | 2 3 1))) :static-draw)) 101 | 102 | 103 | ;;; definition degree-to-radian 104 | (in-ws-repl 105 | (setf *degree* 0.0) 106 | (define-jsfun deg-to-rad (degree) 107 | (/ (* degree pi) 180.0))) 108 | 109 | ;;; draw 110 | (in-ws-repl 111 | (define-jsfun draw-scene () 112 | (let ((bg-color (abs (sin (* .5 (deg-to-rad *degree*)))))) 113 | (gl:clear-color bg-color bg-color bg-color 1.0)) 114 | (gl:clear :color-buffer-bit :depth-buffer-bit) 115 | (gl:viewport 0 0 (@ canvas width) (@ canvas height)) 116 | (mat:perspective p-matrix 45 (/ (@ canvas width) (@ canvas height)) .1 100.) 117 | (mat:identity mv-matrix) 118 | (mat:translate mv-matrix (list -10. 0 -20.)) 119 | (gl:bind-buffer :array-buffer vertex-position-buffer) 120 | (gl:vertex-attrib-pointer (@ shader-program vertex-pos-attrib) 3 :float f 0 0) 121 | (gl:bind-buffer :array-buffer vertex-color-buffer) 122 | (gl:vertex-attrib-pointer (@ shader-program vertex-color-attrib) 3 :float f 0 0) 123 | (gl:bind-buffer :element-array-buffer vertex-indicies-buffer) 124 | (incf *degree* 1) 125 | (dotimes (i 30) 126 | (mat:rotate mv-matrix (deg-to-rad *degree*) (list 1 0 1)) 127 | (mat:translate mv-matrix (list 1 0 0)) 128 | (mat:set-matrix-uniforms) 129 | (gl:draw-elements :triangles 6 :unsigned-short 0)))) 130 | 131 | 132 | ;;; animate! 133 | (in-ws-repl 134 | (define-jsfun animate () 135 | (draw-scene) 136 | (request-animation-frame animate)) 137 | (animate)) 138 | 139 | 140 | -------------------------------------------------------------------------------- /gl.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage #:gl 3 | (:use #:cl #:js #:ps) 4 | (:export #:init-shader)) 5 | 6 | (in-package :gl) 7 | 8 | 9 | ;;; 10 | (defun gl-type (type) 11 | (ecase type 12 | (:float '(chain gl *float*)) 13 | (:unsigned-byte '(chain gl *unsigned_byte*)) 14 | (:unsigned-short '(chain gl *unsigned_short*)))) 15 | 16 | (defun gl-format (format) 17 | (ecase format 18 | (:rgba '(chain gl *rgba*)))) 19 | 20 | (defun gl-draw-mode (mode) 21 | (ecase mode 22 | (:line-strip '(chain gl *line_strip*)) 23 | (:line-loop '(chain gl *line_loop*)) 24 | (:triangles '(chain gl *triangles*)) 25 | (:triangle-strip '(chain gl *triangle_strip*)))) 26 | 27 | (defun gl-clear-mode (mode) 28 | (ecase mode 29 | (:color-buffer-bit '(chain gl *color_buffer_bit*)) 30 | (:depth-buffer-bit '(chain gl *depth_buffer_bit*)))) 31 | 32 | (defun gl-enable-mode (mode) 33 | (ecase mode 34 | (:depth-test '(chain gl *depth_test*)) 35 | (:blend '(chain gl *blend*) ))) 36 | 37 | (defun gl-blend-mode (mode) 38 | (ecase mode 39 | (:src-alpha '(chain gl *src_alpha*)) 40 | (:one '(chain gl *one*)))) 41 | 42 | (defun gl-shader-mode (shader-mode) 43 | (ecase shader-mode 44 | (:vertex-shader '(chain gl *vertex_shader*)) 45 | (:fragment-shader '(chain gl *fragment_shader*)))) 46 | 47 | (defun gl-program-status (status) 48 | (ecase status 49 | (:compile-status '(chain gl *compile_status*)) 50 | (:link-status '(chain gl *link_status*)))) 51 | 52 | (defun gl-buffer-target (target) 53 | (ecase target 54 | (:array-buffer '(chain gl *array_buffer*)) 55 | (:element-array-buffer '(chain gl *element_array_buffer*)))) 56 | 57 | (defun gl-buffer-usage (usage) 58 | (ecase usage 59 | (:static-draw '(chain gl *static_draw*)))) 60 | 61 | (defun gl-texture-unit (unit) 62 | (ecase unit 63 | (:texture0 '(chain gl *texture0*)) 64 | (:texture1 '(chain gl *texture1*)) 65 | (:texture2 '(chain gl *texture2*)) 66 | (:texture3 '(chain gl *texture3*)))) 67 | 68 | (defun gl-texture-target (target) 69 | (ecase target 70 | (:texture-2d '(chain gl *texture_2-d*)))) 71 | 72 | (defun gl-texture-parameter (parameter) 73 | (ecase parameter 74 | (:texture-mag-filter '(chain gl *texture_mag_filter*)) 75 | (:texture-min-filter '(chain gl *texture_min_filter*)) 76 | (:texture-wrap-s '(chain gl *texture_wrap_s*)) 77 | (:texture-wrap-t '(chain gl *texture_wrap_t*)) 78 | (:unpack-flip-y-webgl '(chain gl *unpack_flip_y_webgl*)) 79 | (:unpack-premultiply-alpha-webgl '(chain gl *unpack_premultiply_alpha_webgl*)) 80 | (:unpack-colorspace-convension-webgl '(chain gl *unpack_colorspace_convension_webgl*)))) 81 | 82 | (defun gl-texture-param-name (name) 83 | (ecase name 84 | (:linear '(chain gl *linear*)) 85 | (:nearest '(chain gl *nearest*)) 86 | (:nearest-mipmap-nearest '(chain gl *nearest_mipmap_nearest*)) 87 | (:linear-mipmap-nearest '(chain gl *linear-mimap-nearest*)) 88 | (:nearest-mipmap-linear '(chain gl *nearest_mipmap_linear*)) 89 | (:linear-mipmap-linear '(chain gl *linear_mipmap_linear*)) 90 | (:repeat '(chain gl *repeat*)) 91 | (:clamp-to-edge '(chain gl *clamp_to_edge*)) 92 | (:mirrored-repeat '(chain gl *mirrored_repeat*)))) 93 | 94 | ;;;; 95 | 96 | (define-ps-macro enable (mode) 97 | `(chain gl (enable ,(gl-enable-mode mode)))) 98 | 99 | (define-ps-macro clear-color (r g b a) 100 | `(chain gl (clear-color ,r ,g ,b ,a))) 101 | 102 | (define-ps-macro clear (&rest buffers) 103 | `(chain gl (clear (logior ,@(mapcar #'gl-clear-mode buffers))))) 104 | 105 | (define-ps-macro viewport (x y width height) 106 | `(chain gl (viewport ,x ,y ,width ,height))) 107 | 108 | (define-ps-macro blend-func (src target) 109 | `(chain gl (blend-func ,(gl-blend-mode src) ,(gl-blend-mode target)))) 110 | 111 | (define-ps-macro draw-arrays (mode first count) 112 | `(chain gl (draw-arrays ,(gl-draw-mode mode) ,first ,count))) 113 | 114 | (define-ps-macro draw-elements (mode count type offset) 115 | `(chain gl (draw-elements ,(gl-draw-mode mode) ,count ,(gl-type type) ,offset))) 116 | 117 | ;;; Shader 118 | (define-ps-macro create-program () 119 | `(chain gl (create-program))) 120 | 121 | (define-ps-macro link-program (program) 122 | `(chain gl (link-program ,program))) 123 | 124 | (define-ps-macro use-program (program) 125 | `(chain gl (use-program ,program))) 126 | 127 | (define-ps-macro create-shader (mode) 128 | `(chain gl (create-shader ,(gl-shader-mode mode)))) 129 | 130 | (define-ps-macro shader-source (shader src) 131 | `(chain gl (shader-source ,shader ,src))) 132 | 133 | (define-ps-macro compile-shader (shader) 134 | `(chain gl (compile-shader ,shader))) 135 | 136 | (define-ps-macro attach-shader (program shader) 137 | `(chain gl (attach-shader ,program ,shader))) 138 | 139 | (define-ps-macro get-program-parameter (program pname) 140 | `(chain gl (get-program-parameter ,program ,(gl-program-status pname)))) 141 | 142 | (define-ps-macro get-shader-parameter (shader pname) 143 | `(chain gl (get-shader-parameter ,shader ,(gl-program-status pname)))) 144 | 145 | ;;; inter-shader 146 | (define-ps-macro get-uniform-location (program uniform) 147 | `(chain gl (get-uniform-location ,program ,uniform))) 148 | 149 | (define-ps-macro uniform1i (location value) 150 | `(chain gl (uniform1i ,location ,value))) 151 | 152 | (define-ps-macro uniform1f (location value) 153 | `(chain gl (uniform1f ,location ,value))) 154 | 155 | (define-ps-macro uniform2f (location value1 value2) 156 | `(chain gl (uniform2f ,location ,value1 ,value2))) 157 | 158 | (define-ps-macro uniform3f (location value1 value2 value3) 159 | `(chain gl (uniform3f ,location ,value1 ,value2 ,value3))) 160 | 161 | (define-ps-macro uniform-matrix-3fv (location transpose-p value) 162 | `(chain gl (uniform-matrix-3fv ,location ,transpose-p ,value))) 163 | 164 | (define-ps-macro uniform-matrix-4fv (location transpose-p value) 165 | `(chain gl (uniform-matrix-4fv ,location ,transpose-p ,value))) 166 | 167 | (define-ps-macro get-attrib-location (program name) 168 | `(chain gl (get-attrib-location ,program ,name))) 169 | 170 | (define-ps-macro enable-vertex-attrib-array (index) 171 | `(chain gl (enable-vertex-attrib-array ,index))) 172 | 173 | (define-ps-macro vertex-attrib-pointer (index size type normalized-p stride offset) 174 | `(chain gl (vertex-attrib-pointer ,index ,size ,(gl-type type) ,normalized-p ,stride ,offset))) 175 | 176 | ;;; Buffer 177 | (define-ps-macro create-buffer () 178 | `(chain gl (create-buffer))) 179 | 180 | (define-ps-macro bind-buffer (target buffer) 181 | `(chain gl (bind-buffer ,(gl-buffer-target target) ,buffer))) 182 | 183 | (define-ps-macro buffer-data (target array-buffer-data usage) 184 | `(chain gl (buffer-data ,(gl-buffer-target target) ,array-buffer-data ,(gl-buffer-usage usage)))) 185 | 186 | ;;; Texture 187 | (define-ps-macro create-texture () 188 | `(chain gl (create-texture))) 189 | 190 | (define-ps-macro active-texture (target) 191 | `(chain gl (active-texture ,(gl-texture-unit target)))) 192 | 193 | (define-ps-macro bind-texture (target texture) 194 | `(chain gl (bind-texture ,(gl-texture-target target) ,texture))) 195 | 196 | (define-ps-macro is-texture (texture) 197 | `(chain gl (is-texture ,texture))) 198 | 199 | (define-ps-macro delete-texture (texture) 200 | `(chain gl (delete-texture ,texture))) 201 | 202 | (define-ps-macro tex-image-2d (target level internal-format format type source) 203 | `(chain gl (tex-image-2-d ,(gl-texture-target target) ,level ,(gl-format internal-format) 204 | ,(gl-format format) 205 | ,(gl-type type) ,source))) 206 | 207 | (define-ps-macro tex-image-2d-array (target level internal-format width height border format type pixels) 208 | `(chain gl (tex-image-2-d ,(gl-texture-target target) ,level 209 | ,(gl-format internal-format) ,width ,height ,border 210 | ,(gl-format format) ,(gl-type type) ,pixels))) 211 | 212 | (define-ps-macro tex-parameteri (target param-name param) 213 | `(chain gl (tex-parameteri ,(gl-texture-target target) ,(gl-texture-parameter param-name) 214 | ,(gl-texture-param-name param)))) 215 | 216 | (define-ps-macro get-tex-parameter (target pname) 217 | `(chain gl (get-tex-parameter ,(gl-texture-target target) ,(gl-texture-parameter pname)))) 218 | 219 | (define-ps-macro pixel-storei (pname param) 220 | `(chain gl (pixel-storei ,(gl-texture-parameter pname) ,param))) 221 | 222 | (define-ps-macro generate-mipmap (target) 223 | `(chain gl (generate-mipmap ,(gl-texture-target target)))) 224 | 225 | 226 | 227 | ;;; 228 | (defpsmacro install-init-shader () 229 | `(setf init-shader 230 | (lambda (vs-src fs-src) 231 | (let* ((gl-program (create-program)) 232 | (vs-shader (create-shader :vertex-shader)) 233 | (fs-shader (create-shader :fragment-shader))) 234 | (shader-source vs-shader vs-src) 235 | (shader-source fs-shader fs-src) 236 | (compile-shader vs-shader) 237 | (unless (get-shader-parameter vs-shader :compile-status) 238 | (alert (chain gl (get-shader-info-log vs-shader)))) 239 | (compile-shader fs-shader) 240 | (unless (get-shader-parameter fs-shader :compile-status) 241 | (alert (chain gl (get-shader-info-log fs-shader)))) 242 | (attach-shader gl-program vs-shader) 243 | (attach-shader gl-program fs-shader) 244 | (link-program gl-program) 245 | (unless (get-program-parameter gl-program :link-status) 246 | (alert "Could not initialise shaders")) 247 | gl-program)))) 248 | 249 | ;;; dummy... 250 | (defun init-shader (vs-src fs-src) 251 | (declare (ignore vs-src fs-src))) 252 | 253 | (define-ps-macro with-gl-canvas ((var canvas-id &optional option) &body body) 254 | `(progn (setf ,var (chain document (get-element-by-id ,canvas-id))) 255 | (setf gl (or (chain ,var (get-context "webgl" ,option )) 256 | (chain ,var (get-context "experimental-webgl" ,option)))) 257 | (unless gl 258 | (alert "error: your browser does not appear to support webgl")) 259 | (install-init-shader) 260 | ,@body 261 | "undefined")) 262 | 263 | --------------------------------------------------------------------------------