#!chezscheme

(library
 (cairo)
 (export 
  cairo-library-init
  cairo-version cairo-version-string cairo-create 
................................................................................
  cairo-region-subtract cairo-region-subtract-rectangle
  cairo-region-intersect cairo-region-intersect-rectangle
  cairo-region-union cairo-region-union-rectangle cairo-region-xor
  cairo-region-xor-rectangle cairo-debug-reset-static-data
  cairo-pdf-surface-create cairo-pdf-surface-create-for-stream
  cairo-pdf-surface-restrict-to-version cairo-pdf-get-versions
  cairo-pdf-version-to-string cairo-pdf-surface-set-size





  cairo-bool-t
  cairo-t
  cairo-surface-t
  cairo-device-t
  cairo-matrix-t
  cairo-pattern-t
  cairo-destroy-func-t
................................................................................
		  [(ftype-pointer? cairo-device-t p) (cairo-device-destroy p)]
		  [else
		   (foreign-free (ftype-pointer-address p))]
		  ))
	   (loop (cairo-guardian)))))		

(include "cairo/cairo-functions.ss")

(include "cairo/cairo-pdf-functions.ss")












) ; library cairo

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

#!chezscheme

(library
 (cairo)
 (export 
  cairo-library-init
  cairo-version cairo-version-string cairo-create 
................................................................................
  cairo-region-subtract cairo-region-subtract-rectangle
  cairo-region-intersect cairo-region-intersect-rectangle
  cairo-region-union cairo-region-union-rectangle cairo-region-xor
  cairo-region-xor-rectangle cairo-debug-reset-static-data
  cairo-pdf-surface-create cairo-pdf-surface-create-for-stream
  cairo-pdf-surface-restrict-to-version cairo-pdf-get-versions
  cairo-pdf-version-to-string cairo-pdf-surface-set-size

  cairo-set-source-color
  color-r color-g color-b color-a
  make-color color?

  cairo-bool-t
  cairo-t
  cairo-surface-t
  cairo-device-t
  cairo-matrix-t
  cairo-pattern-t
  cairo-destroy-func-t
................................................................................
		  [(ftype-pointer? cairo-device-t p) (cairo-device-destroy p)]
		  [else
		   (foreign-free (ftype-pointer-address p))]
		  ))
	   (loop (cairo-guardian)))))		

(include "cairo/cairo-functions.ss")

(include "cairo/cairo-pdf-functions.ss")

(define-record-type (color mkcolor color?) 
  (fields r g b a))

(define make-color
  (case-lambda
   [(r g b) (mkcolor r g b 1.0)]
   [(r g b a) (mkcolor r g b a)]))
  
(define (cairo-set-source-color ctx c)
  (cairo-set-source-rgba ctx (color-r c) (color-g c) (color-b c) (color-a c)))

) ; library cairo

 (define-syntax define-cairo-func
   (lambda (x)
     (define (string-replace s x y)
       (list->string  
	(let ([cmp (if (list? x) memq eq?)])
	  (map (lambda (z) (if (cmp z x) y z)) (string->list s)))))
................................................................................
			     get-group-target copy-path copy-path-flat
			     append-path status select-font-face
			     set-font-size set-font-matrix get-font-matrix
			     set-font-options get-font-options set-font-face
			     get-font-face set-scaled-font get-scaled-font
			     show-text show-glyphs show-text-glyphs
			     text-path glyph-path text-extents
			     glyph-extents font-extents ))

     (define (rename-cairo name)
       (string->symbol (string-append "cairo-" (symbol->string name))))
     (syntax-case x ()
       [(_ context application ...)
	(with-syntax ([(forms ...) 
		       (map (lambda (y) 
			      (let ([y* (syntax->datum y)])

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-syntax define-cairo-func
   (lambda (x)
     (define (string-replace s x y)
       (list->string  
	(let ([cmp (if (list? x) memq eq?)])
	  (map (lambda (z) (if (cmp z x) y z)) (string->list s)))))
................................................................................
			     get-group-target copy-path copy-path-flat
			     append-path status select-font-face
			     set-font-size set-font-matrix get-font-matrix
			     set-font-options get-font-options set-font-face
			     get-font-face set-scaled-font get-scaled-font
			     show-text show-glyphs show-text-glyphs
			     text-path glyph-path text-extents
			     glyph-extents font-extents
			     set-source-color))
     (define (rename-cairo name)
       (string->symbol (string-append "cairo-" (symbol->string name))))
     (syntax-case x ()
       [(_ context application ...)
	(with-syntax ([(forms ...) 
		       (map (lambda (y) 
			      (let ([y* (syntax->datum y)])

(import (scheme)
	(json))

(import (only (thunder-utils) string-replace string-split) 
	(only (srfi s13 strings) string-drop string-downcase string-prefix? string-suffix? string-delete)
	(only (srfi s1 lists) fold)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

(import (scheme)
	(json))

(import (only (thunder-utils) string-replace string-split) 
	(only (srfi s13 strings) string-drop string-downcase string-prefix? string-suffix? string-delete)
	(only (srfi s1 lists) fold)

(import (cairo))

(cairo-library-init)
(define pi 3.1415926536)

(define (test-cairo name proc) 
  (let* ([surface (cairo-image-surface-create (cairo-format 'argb-32) 120 120)]

(import (cairo))

(cairo-library-init)
(define pi 3.1415926536)

(define (test-cairo name proc) 
  (let* ([surface (cairo-image-surface-create (cairo-format 'argb-32) 120 120)]

 (define-ftype unsigned-char unsigned-8)
 (define-ftype cairo-bool-t int)
 (define-ftype cairo-t (struct))

 (define-ftype cairo-surface-t (struct))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype unsigned-char unsigned-8)
 (define-ftype cairo-bool-t int)
 (define-ftype cairo-t (struct))

 (define-ftype cairo-surface-t (struct))

#!chezscheme


















(library (ffi-utils)

	 (export define-enumeration* define-function define-flags make-flags flags flags-name flags-alist flags-indexer flags-ref-maker flags-decode-maker)

	 (import (chezscheme))



	 







 ;; Uses make-enumeration to define an enum with the following:
 ;; function (name x) -> index
 ;; function (name-ref index) -> symbol
 ;; variable name-enum  -> #>enum-set>

 ;; usage: (define-enumeration* NAME (tag1 tag2 tag3 ...))

 (define-syntax define-enumeration*
   (lambda (x)
     (define gen-id
       (lambda (template-id . args)
	 (datum->syntax
	  template-id
	  (string->symbol
	   (apply
	    string-append
	    (map (lambda (x)
		   (if (string? x) x (symbol->string (syntax->datum x))))
		 args))))))
     (syntax-case x ()
       [(_ name (l ...))
	(with-syntax ([base-name (gen-id #'name "" #'name)]
		      [enum-name (gen-id #'name #'name "-enum")]
		      [ref-name (gen-id #'name #'name "-ref")])


		     #'(begin
			 (define enum-name (make-enumeration '(l ...)))
			 (define base-name
			   (lambda (x)
			     (let ([r ((enum-set-indexer enum-name) x)])
			       (if r
				   r
				   (assertion-violation 'enum-name
							"symbol not found"
							x)))))
			 (define ref-name
			   (lambda (index)
			     (list-ref (enum-set->list enum-name) index)))
			 (indirect-export base-name enum-name ref-name)))])))


;; ;; TODO: WRITE SOME AUTOMATED TYPE CHECKS/CONVERSIONS

;;  (define ffi-types-conversion-list (make-parameter '()))
;;  (define-record ffi-type (name >scheme >c ffi-name))

;;  (define (find-ffi-type t)
;;    (find (lambda (x) (equal? (ffi-type-name x) t)) (ffi-types-conversion-list)))
   
;;  (define-syntax define-function
;;    (lambda (x)
;;      (define (rename-type t) (datum->syntax t (cond [(find-ffi-type (syntax->datum t)) 
;; 						       => (lambda (ft) (ffi-type-ffi-name ft))]
;; 						      [else (syntax->datum t)])))
;;      (define (rename-types ls)
;;        (let loop ([ls ls] [collect '()])
;; 	 (if (null? ls) (reverse collect)
;; 	     (loop (cdr ls) (cons (rename-type (car ls)) collect)))))

;;      (define (value->c x)
;;        (let ([type (syntax->datum (cadr x))] [name (syntax->datum (car x))])
;; 	 (let ([t (find-ffi-type type)])
;; 	   (if t ((ffi-type->c t) name)
;; 	       name))))
      
;;      (syntax-case x ()
;;        ; WITH NAME+TYPE ARGUMENTS , this is nice because you can catch the argument name if some error happens
;;        ; In any case it is handy to have the argument names also in the scheme declarations for quick reference.
;;        ; We could also ignore them in expansion time
;;        [(_ name ((arg-name arg-type) ...) ret)
;; 	(with-syntax ([args/types #'((arg-name arg-type) ...)]
;; 		      [types-list #'(arg-type ...)]
;; 		      [renamed-types (rename-types #'(arg-type ...))]
;; 		      [renamed-ret (rename-type #'ret)]
;; 		      [name/string (symbol->string (syntax->datum #'name))])
;; 		     (with-syntax ([(values ...) 
;; 				    (map (lambda (x)
;; 					   (let ([ft (datum->syntax #'x (value->c x )) ])
;; 					     ft))
;; 					     #'args/types)])
;; 				  #'(define (name arg-name ...)
				      
;; 				      ((foreign-procedure name/string renamed-types renamed-ret) 
;; 				       values ...))))])))
;;        ; WITH ONLY ARGUMENT TYPES
;;        [(_ name (args ...) ret)
;; 	#'(define name
;; 	    (foreign-procedure (symbol->string 'name) (args ...) ret))])))

 (define-syntax define-function
   (lambda (x)
     (syntax-case x ()

       [(_ name ((arg-name arg-type) ...) ret)
	#'(define name 
	    (lambda (arg-name ...)
	      (foreign-procedure (symbol->string name) (arg-type ...) ret)))]
       ;; WITH ONLY ARGUMENT TYPES
       [(_ name (args ...) ret)



	#'(define name
	    (foreign-procedure (symbol->string 'name) (args ...) ret))])))

(define-syntax define-function*
  (lambda (x)
    (define (rename-scheme->c type)
      type)
................................................................................
;> (color 'blue) -> 2
;> (color 'red 'blue) -> 3
;> (color 'black) -> Exception in color: symbol not found with irritant (black)
;> (color-ref 1) -> red
;> (color-ref 5) -> #f
;> (color-decode 3) -> (red blue)
;> (color-decode 16) -> ()
;> (color-decode 6) -> (blue green) !!! ATTENTION
;> (flags-alist color-flags) -> ((red . 1) (blue . 2) (green . 4))
;> (flags-name color-flags) -> color

;; TODO, what to do for value 0?

 (define-syntax define-flags
   (lambda (x)
     (define gen-id
       (lambda (template-id . args)
	 (datum->syntax
	  template-id
	  (string->symbol
	   (apply
	    string-append
	    (map (lambda (x)
		   (if (string? x) x (symbol->string (syntax->datum x))))
		 args))))))
     (syntax-case x ()
       [(_ name (k  v) ...)
	(with-syntax ([base-name (gen-id #'name "" #'name)]
		      [flags-name (gen-id #'name #'name "-flags")]
		      [ref-name (gen-id #'name #'name "-ref")]
		      [decode-name (gen-id #'name #'name "-decode")])
		     #'(begin
			 (define flags-name (make-flags 'name (list (cons 'k v) ...)))
			 (define base-name (flags-indexer flags-name))
			 (define ref-name (flags-ref-maker flags-name))
			 (define decode-name (flags-decode-maker flags-name))
			 (indirect-export base-name flags-name ref-name decode-name flags-indexer flags-ref-maker flags-decode-maker)))])))

 (define-record flags (name alist))
 
 (define (flags-indexer  flags)
   (lambda (name . more-names)
     (let ([names (append (list name) more-names)])
       (let loop ([f names] [result 0])
	 (if (null? f) result
................................................................................
     (let loop ([l (flags-alist flags)] [result '()])
       (if (null? l) result
	   (let ([item (car l)])
	     (if (zero? (logand (cdr item) mask))
		 (loop (cdr l) result)
		 (loop (cdr l) (append result (list (car item))))))))))
 






































 ); library ffi-utils

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

#!r6rs

(library
 (ffi-utils)
 (export define-enumeration* define-function 
	 define-flags make-flags flags flags-name flags-alist flags-indexer flags-ref-maker flags-decode-maker
	 let-struct)
 (import (chezscheme))

;; TODO: maybe we should support multiple structs?
;; and maybe also normal let entries? let-struct* also?

 (define-syntax let-struct
   (lambda (x)
     (syntax-case x ()
       [(_ object ftype-name (field ...) body ...)
	#'(let ([field (ftype-ref ftype-name (field) object)] ...)
	    body ...)])))

 ;; Uses make-enumeration to define an enum with the following:
 ;; function (name x) -> index
 ;; function (name-ref index) -> symbol
 ;; variable name-enum  -> #>enum-set>
 ;; name-t -> ftype int
 ;; usage: (define-enumeration* NAME (tag1 tag2 tag3 ...))

 (define-syntax define-enumeration*
   (lambda (x)
     (define gen-id
       (lambda (template-id . args)
	 (datum->syntax
	  template-id
	  (string->symbol

	   (apply string-append
		  (map (lambda (x)
			 (if (string? x) x (symbol->string (syntax->datum x))))
		       args))))))
     (syntax-case x ()
       [(_ name (l ...))
	(with-syntax ([base-name (gen-id #'name "" #'name)]
		      [enum-name (gen-id #'name #'name "-enum")]
		      [ref-name (gen-id #'name #'name "-ref")]
		      [name/t (gen-id #'name #'name "-t")])
		     (indirect-export base-name enum-name ref-name name/t)
		     #'(begin
			 (define enum-name (make-enumeration '(l ...)))
			 (define base-name
			   (lambda (x)
			     (let ([r ((enum-set-indexer enum-name) x)])
			       (if r r

				   (assertion-violation 'enum-name
							"symbol not found"
							x)))))
			 (define ref-name
			   (lambda (index)
			     (list-ref (enum-set->list enum-name) index)))

			 (define-ftype name/t int)))])))









 (define-syntax define-function
   (lambda (x)














     (syntax-case x ()



       [(_ name ((arg-name arg-type) ...) ret)
















	#'(define name 



	    (lambda (arg-name ...)

	      (foreign-procedure (symbol->string name) (arg-type ...) ret)))]
       [(_ ret name ((arg-name arg-type) ...))
	#'(define name 
	    (lambda (arg-name ...)
	      (foreign-procedure (symbol->string name) (arg-type ...) ret)))]
       ;; WITH ONLY ARGUMENT TYPES
       [(_ name (args ...) ret)
	#'(define name
	    (foreign-procedure (symbol->string 'name) (args ...) ret))]
       [(_ ret name (args ...))
	#'(define name
	    (foreign-procedure (symbol->string 'name) (args ...) ret))])))

(define-syntax define-function*
  (lambda (x)
    (define (rename-scheme->c type)
      type)
................................................................................
;> (color 'blue) -> 2
;> (color 'red 'blue) -> 3
;> (color 'black) -> Exception in color: symbol not found with irritant (black)
;> (color-ref 1) -> red
;> (color-ref 5) -> #f
;> (color-decode 3) -> (red blue)
;> (color-decode 16) -> ()
;> (color-decode 6) -> (blue green) !!! ATTENTION should raise exception?
;> (flags-alist color-flags) -> ((red . 1) (blue . 2) (green . 4))
;> (flags-name color-flags) -> color

;; TODO, what to do for value 0?


























 (define-record flags (name alist))
 
 (define (flags-indexer  flags)
   (lambda (name . more-names)
     (let ([names (append (list name) more-names)])
       (let loop ([f names] [result 0])
	 (if (null? f) result
................................................................................
     (let loop ([l (flags-alist flags)] [result '()])
       (if (null? l) result
	   (let ([item (car l)])
	     (if (zero? (logand (cdr item) mask))
		 (loop (cdr l) result)
		 (loop (cdr l) (append result (list (car item))))))))))
 
 (define-syntax define-flags
   (lambda (x)
     (define gen-id
       (lambda (template-id . args)
	 (datum->syntax
	  template-id
	  (string->symbol
	   (apply
	    string-append
	    (map (lambda (x)
		   (if (string? x) x (symbol->string (syntax->datum x))))
		 args))))))
     (syntax-case x ()
       [(ka name (k  v) ...)
	#'(ka name int (k v) ...)] 
       [(y name type (k  v) ...)
	(with-syntax ([base-name (gen-id #'y "" #'name)]
		      [flags-name (gen-id #'y #'name "-flags")]
		      [ref-name (gen-id #'y #'name "-ref")]
		      [decode-name (gen-id #'y #'name "-decode")]
		      [name-t (gen-id #'y #'name "-t")]
		      #;[(v1 ...) (map (lambda (v)  
					  (if (char? (datum v))
					       (datum->syntax #'v (char->integer (datum v)))
					      v))
				        #'(v ...) )])
		     
		     (indirect-export flags-indexer flags-ref-maker flags-decode-maker)
		     #`(begin 
		;	 (import (ffi-utils))
			 (define flags-name (make-flags 'name (list (cons 'k v) ...)))
			 (define base-name (flags-indexer flags-name))
			 (define ref-name (flags-ref-maker flags-name))
			 (define decode-name (flags-decode-maker flags-name))
			 (define-ftype name-t type)
			 ;(indirect-export base-name flags-name ref-name decode-name name-t )
			 ))])))

 ); library ffi-utils

#!chezscheme
(library 
 (json)
 (export parse-json-str read-file let-json-object string->json)
 (import (srfi s14 char-sets)
	 (scheme))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

#!chezscheme
(library 
 (json)
 (export parse-json-str read-file let-json-object string->json)
 (import (srfi s14 char-sets)
	 (scheme))

#!r6rs
(library 
 (lmdb) 
 (export
  mdb-version mdb-strerror mdb-env-create mdb-env-open mdb-env-copy
  mdb-env-copyfd mdb-env-copy2 mdb-env-copyfd2 mdb-env-stat mdb-env-info
  mdb-env-sync mdb-env-close mdb-env-set-flags mdb-env-get-flags

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

#!r6rs
(library 
 (lmdb) 
 (export
  mdb-version mdb-strerror mdb-env-create mdb-env-open mdb-env-copy
  mdb-env-copyfd mdb-env-copy2 mdb-env-copyfd2 mdb-env-stat mdb-env-info
  mdb-env-sync mdb-env-close mdb-env-set-flags mdb-env-get-flags

 (define-syntax mdb-define
   (syntax-rules ()
     ((_ name n) 
      (define-syntax name (identifier-syntax n)))))

(mdb-define MDB_SUCCESS	 0)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-syntax mdb-define
   (syntax-rules ()
     ((_ name n) 
      (define-syntax name (identifier-syntax n)))))

(mdb-define MDB_SUCCESS	 0)

(define-enumeration* mdb-cursor-op
  (first			;;< Position at first key/data item */
   first-dup		;;< Position at first data item of current key.
   ;;Only for #DUPSORT */
   get-both		;;< Position at key/data pair. Only for #DUPSORT */
   get-both-range	;;< position at key, nearest data. Only for #DUPSORT */

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-enumeration* mdb-cursor-op
  (first			;;< Position at first key/data item */
   first-dup		;;< Position at first data item of current key.
   ;;Only for #DUPSORT */
   get-both		;;< Position at key/data pair. Only for #DUPSORT */
   get-both-range	;;< position at key, nearest data. Only for #DUPSORT */

;; FIXME #ifdef_MSC_VER

 (define-ftype mdb-mode-t int) ;;//?!?!?! FIXME
 (define-ftype mdb-size-t integer-64)

;; FIXME #ifdef _WIN32

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

;; FIXME #ifdef_MSC_VER

 (define-ftype mdb-mode-t int) ;;//?!?!?! FIXME
 (define-ftype mdb-size-t integer-64)

;; FIXME #ifdef _WIN32

 (define mdb-guardian (make-guardian))
 (define (mdb-guard-pointer obj) 
   (mdb-free-garbage) 
   ;(printf "guarding pointer ~d~n" obj)
   (mdb-guardian obj)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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 mdb-guardian (make-guardian))
 (define (mdb-guard-pointer obj) 
   (mdb-free-garbage) 
   ;(printf "guarding pointer ~d~n" obj)
   (mdb-guardian obj)

(import (lmdb))
(mdb-library-init)

(random-seed (time-nanosecond (current-time)))

(define count (+ (random 384) 64))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

(import (lmdb))
(mdb-library-init)

(random-seed (time-nanosecond (current-time)))

(define count (+ (random 384) 64))

(import (scheme)
	(json))

(import (only (thunder-utils) string-replace string-split) 
	(only (srfi s13 strings) string-drop string-downcase string-prefix? string-suffix? string-delete)
	(only (srfi s1 lists) fold)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

(import (scheme)
	(json))

(import (only (thunder-utils) string-replace string-split) 
	(only (srfi s13 strings) string-drop string-downcase string-prefix? string-suffix? string-delete)
	(only (srfi s1 lists) fold)

;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation files
;;; (the "Software"), to deal in the Software without restriction,
;;; including without limitation the rights to use, copy, modify, merge,
;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;; and to permit persons to whom the Software is furnished to do so,
;;; subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

;;; This program was originally designed and implemented by Dan Friedman.
;;; It was redesigned and reimplemented by Erik Hilsdale.  Additional
;;; modifications were made by Kent Dybvig, Steve Ganz, and Aziz Ghuloum.
;;; Parts of the implementation were adapted from the portable syntax-case
;;; implementation written by Kent Dybvig, Oscar Waddell, Bob Hieb, and
;;; Carl Bruggeman and is used by permission of Cadence Research Systems.

;;; A change log appears at end of this file.
................................................................................
;;         || ,[Cata -> Id*]
;;         || Id

;; Cata   ::= Exp

;; YOU'RE NOT ALLOWED TO REFER TO CATA VARS IN GUARDS. (reasonable!)

#!chezscheme
(library
 (match)
 (export match+ match-help match-help1 clause-body let-values**
         guard-body convert-pat mapper my-backquote extend-backquote
         sexp-dispatch
         trace-match+ match-help match-help1 clause-body let-values**
         guard-body convert-pat mapper my-backquote extend-backquote
         sexp-dispatch
         match match-help match-help1 clause-body let-values**
         guard-body convert-pat mapper my-backquote extend-backquote
         sexp-dispatch
         trace-match match-help match-help1 clause-body let-values**
         guard-body convert-pat mapper my-backquote extend-backquote
         sexp-dispatch
         with-ellipsis-aware-quasiquote my-backquote
         match-equality-test)

 (import (scheme))

 (define match-equality-test
   (make-parameter
    equal?
    (lambda (x)
      (unless (procedure? x)
        (error 'match-equality-test "~s is not a procedure" x))
      x)))

 (define-syntax match+
   (lambda (x)
     (syntax-case x ()
       [(k (ThreadedId ...) Exp Clause ...)
        #'(let f ((ThreadedId ThreadedId) ... (x Exp))
            (match-help k f x (ThreadedId ...) Clause ...))])))

 (define-syntax match
   (lambda (x)
     (syntax-case x ()
       [(k Exp Clause ...)
        #'(let f ((x Exp))
            (match-help k f x () Clause ...))])))

 (define-syntax trace-match+
   (lambda (x)
     (syntax-case x ()
       [(k (ThreadedId ...) Name Exp Clause ...)
        #'(letrec ((f (trace-lambda Name (ThreadedId ... x)
                                    (match-help k f x (ThreadedId ...) Clause ...))))
            (f ThreadedId ... x))])))

 (define-syntax trace-match
   (lambda (x)
     (syntax-case x ()
       [(k Name Exp Clause ...)
        #'(letrec ((f (trace-lambda Name (x)
                                    (match-help k f x () Clause ...))))
            (f Exp))])))

;;; ------------------------------

 (define-syntax let-values**
   (syntax-rules ()
     ((_ () B0 B ...) (begin B0 B ...))
     ((_ ((Formals Exp) Rest ...) B0 B ...)
      (let-values** (Rest ...)
                    (call-with-values (lambda () Exp)
                      (lambda Formals B0 B ...))))))

 (define-syntax match-help
   (lambda (x)
     (syntax-case x ()
       ((_ Template Cata Obj ThreadedIds)
        #'(error 'match "Unmatched datum: ~s" Obj))
       ((_ Template Cata Obj ThreadedIds (Pat B0 B ...) Rest ...)
        #'(convert-pat Pat
                       (match-help1 Template Cata Obj ThreadedIds
                                    (B0 B ...)
                                    Rest ...)))
       ((_ Template Cata Obj ThreadedIds cls Rest ...)
        (syntax-error #'cls "invalid match clause")))))

 (define-syntax match-help1
   (lambda (x)
     (syntax-case x (guard)
       [(_ PatLit Vars () Cdecls Template Cata Obj ThreadedIds
           ((guard) B0 B ...) Rest ...)
        #'(let ((ls/false (sexp-dispatch Obj PatLit)))
            (if ls/false
                (apply (lambda Vars
                         (clause-body Cata Cdecls ThreadedIds
                                      (extend-backquote Template B0 B ...)))
                       ls/false)
                (match-help Template Cata Obj ThreadedIds Rest ...)))]
       [(_ PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
           ((guard G ...) B0 B ...) Rest ...)
        #'(let ((ls/false (sexp-dispatch Obj PatLit)))
            (if (and ls/false (apply (lambda Vars
                                       (guard-body Cdecls
                                                   (extend-backquote Template
                                                                     (and PG ... G ...))))
                                     ls/false))
                (apply (lambda Vars
                         (clause-body Cata Cdecls ThreadedIds
                                      (extend-backquote Template B0 B ...)))
                       ls/false)
                (match-help Template Cata Obj ThreadedIds Rest ...)))]
       [(_ PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
           (B0 B ...) Rest ...)
        #'(match-help1 PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
                       ((guard) B0 B ...) Rest ...)])))

 (define-syntax clause-body
   (lambda (x)
     (define build-mapper
       (lambda (vars depth cata tIds)
         (if (zero? depth)
             cata
             (with-syntax ((rest (build-mapper vars (- depth 1) cata tIds))
                           (vars vars)
                           (tIds tIds))
               #'(mapper rest vars tIds)))))
     (syntax-case x ()
       ((_ Cata ((CVar CDepth CMyCata CFormal ...) ...) (ThreadedId ...) B)
        (with-syntax (((Mapper ...)
                       (map (lambda (mycata formals depth)
                              (build-mapper formals
                                            (syntax->datum depth)
                                            (syntax-case mycata ()
                                              [#f #'Cata]
                                              [exp #'exp])
                                            #'(ThreadedId ...)))
                            #'(CMyCata ...)
                            #'((CFormal ...) ...)
                            #'(CDepth ...))))
          #'(let-values** (([ThreadedId ... CFormal ...]
                            (Mapper ThreadedId ... CVar))
                           ...)
                          B))))))

 (define-syntax guard-body
   (lambda (x)
     (syntax-case x ()
       ((_ ((Cvar Cdepth MyCata Cformal ...) ...) B)
        (with-syntax (((CF ...) (apply append #'((Cformal ...) ...))))
          #'(let-syntax
                ((CF
                  (lambda (x)
                    (syntax-case x ()
                      (Name
                       (syntax-error #'Name
                                     "guard cannot refer to return-value variable")))))
                 ...)
              B))))))

 (define-syntax convert-pat
   ;; returns sexp-pat x vars x guards x cdecls
   (let ()
     (define ellipsis?
       (lambda (x)
         (and (identifier? x) (free-identifier=? x #'(... ...)))))
     (define Var?
       (lambda (x)
         (syntax-case x (->)
           [-> #f]
           [id (identifier? #'id)])))
     (define fVar
       (lambda (var vars guards)
         (let loop ([ls vars])
           (if (null? ls)
               (values (cons var vars) guards)
               (if (bound-identifier=? var (car ls))
                   (with-syntax ([(tmp) (generate-temporaries (list var))]
                                 [var (car ls)])
                     (values (cons #'tmp vars)
                             (cons #'((match-equality-test) tmp var) guards)))
                   (loop (cdr ls)))))))
     (define (f syn vars guards cdecls depth)
       (syntax-case syn (unquote)
         ((unquote . stuff) ; separate for better error detection
          (syntax-case syn (unquote ->)
            ((unquote [MyCata -> Var ...])
             (andmap Var? #'(Var ...))
             (with-syntax (((Temp) (generate-temporaries '(x)))
                           (Depth depth))
               (values #'any
                       (cons #'Temp vars)
                       guards
                       (cons #'[Temp Depth MyCata Var ...] cdecls))))
            ((unquote [Var ...])
             (andmap Var? #'(Var ...))
             (with-syntax (((Temp) (generate-temporaries '(x)))
                           (Depth depth))
               (values #'any
                       (cons #'Temp vars)
                       guards
                       (cons #'[Temp Depth #f Var ...] cdecls))))
            ((unquote Var)
             (Var? #'Var)
             (let-synvalues* ([(vars guards) (fVar #'Var vars guards)])
                             (values #'any #'vars #'guards cdecls)))))
         (((unquote . stuff) Dots)
          (ellipsis? #'Dots)
          (syntax-case syn (unquote ->)
            (((unquote [MyCata -> Var ...]) Dots)
             (andmap Var? #'(Var ...))
             (with-syntax (((Temp) (generate-temporaries '(x)))
                           (Depth+1 (add1 depth)))
               (values #'each-any
                       (cons #'Temp vars)
                       guards
                       (cons #'[Temp Depth+1 MyCata Var ...] cdecls))))
            (((unquote [Var ...]) Dots)
             (andmap Var? #'(Var ...))
             (with-syntax (((Temp) (generate-temporaries '(x)))
                           (Depth+1 (add1 depth)))
               (values #'each-any
                       (cons #'Temp vars)
                       guards
                       (cons #'[Temp Depth+1 #f Var ...] cdecls))))
            (((unquote Var) Dots)
             (Var? #'Var)
             (let-synvalues* ([(vars guards) (fVar #'Var vars guards)])
                             (values #'each-any #'vars #'guards cdecls)))
            ((expr Dots) (syntax-error #'expr "match-pattern unquote syntax"))))
         ((Pat Dots)
          (ellipsis? #'Dots)
          (let-synvalues* (((Dpat Dvars Dguards Dcdecls)
                            (f #'Pat vars guards cdecls (add1 depth))))
                          (with-syntax ((Size (- (length #'Dvars) (length vars))))
                            (values #'#(each Dpat Size) #'Dvars #'Dguards #'Dcdecls))))
         ((Pat Dots . Rest)
          (ellipsis? #'Dots)
          (let-synvalues* (((Rpat Rvars Rguards Rcdecls)
                            (f #'Rest vars guards cdecls depth))
                           ((Dpat Dvars Dguards Dcdecls)
                            (f #'(Pat (... ...)) #'Rvars #'Rguards #'Rcdecls
                               depth)))
                          (with-syntax ((Size (- (length #'Dvars) (length #'Rvars)))
                                        ((RevRestTl . RevRest) (reverseX #'Rpat '())))
                            (values #'#(tail-each Dpat Size RevRest RevRestTl)
                                    #'Dvars #'Dguards #'Dcdecls))))
         ((X . Y)
          (let-synvalues* (((Ypat Yvars Yguards Ycdecls)
                            (f #'Y vars guards cdecls depth))
                           ((Xpat Xvars Xguards Xcdecls)
                            (f #'X #'Yvars #'Yguards #'Ycdecls depth)))
                          (values #'(Xpat . Ypat) #'Xvars #'Xguards #'Xcdecls)))
         (() (values #'() vars guards cdecls))
         (#(X ...)
          (let-synvalues* (((Pat Vars Eqvars Cdecls)
                            (f #'(X ...) vars guards cdecls depth)))
                          (values #'#(vector Pat) #'Vars #'Eqvars #'Cdecls)))
         (Thing (values #'#(atom Thing) vars guards cdecls))))
     (define reverseX
       (lambda (ls acc)
         (if (pair? ls)
             (reverseX (cdr ls) (cons (car ls) acc))
             (cons ls acc))))
     (define-syntax let-synvalues*
       (syntax-rules ()
         ((_ () B0 B ...) (begin B0 B ...))
         ((_ (((Formal ...) Exp) Decl ...) B0 B ...)
          (call-with-values (lambda () Exp)
            (lambda (Formal ...)
              (with-syntax ((Formal Formal) ...)
                (let-synvalues* (Decl ...) B0 B ...)))))))
     (lambda (syn)
       (syntax-case syn ()
         ((_ syn (kh . kt))
          (let-synvalues* (((Pat Vars Guards Cdecls) (f #'syn '() '() '() 0)))
                          #'(kh 'Pat Vars Guards Cdecls . kt)))))))

 (define-syntax mapper
   (lambda (x)
     (syntax-case x ()
       ((_ F (RetId ...) (ThreadId ...))
        (with-syntax (((t ...) (generate-temporaries #'(RetId ...)))
                      ((ts ...) (generate-temporaries #'(RetId ...)))
                      ((null ...) (map (lambda (x) #''()) #'(RetId ...))))
          #'(let ((fun F))
              (rec g
                   (lambda (ThreadId ... ls)
                     (if (null? ls)
                         (values ThreadId ... null ...)
                         (call-with-values
                             (lambda () (g ThreadId ... (cdr ls)))
                           (lambda (ThreadId ... ts ...)
                             (call-with-values
                                 (lambda () (fun ThreadId ... (car ls)))
                               (lambda (ThreadId ... t ...)
                                 (values ThreadId ... (cons t ts) ...))))))))))))))

;;; ------------------------------

 (define-syntax my-backquote
   (lambda (x)
     (define ellipsis?
       (lambda (x)
         (and (identifier? x) (free-identifier=? x #'(... ...)))))
     (define-syntax with-values
       (syntax-rules ()
         ((_ P C) (call-with-values (lambda () P) C))))
     (define-syntax syntax-lambda
       (lambda (x)
         (syntax-case x ()
           ((_ (Pat ...) Body0 Body ...)
            (with-syntax (((X ...) (generate-temporaries #'(Pat ...))))
              #'(lambda (X ...)
                  (with-syntax ((Pat X) ...)
                    Body0 Body ...)))))))
     (define-syntax with-temp
       (syntax-rules ()
         ((_ V Body0 Body ...)
          (with-syntax (((V) (generate-temporaries '(x))))
            Body0 Body ...))))
     (define-syntax with-temps
       (syntax-rules ()
         ((_ (V ...) (Exp ...) Body0 Body ...)
          (with-syntax (((V ...) (generate-temporaries #'(Exp ...))))
            Body0 Body ...))))
     (define destruct
       (lambda (Orig x depth)
         (syntax-case x (quasiquote unquote unquote-splicing)
           ;; inner quasiquote
           ((Exp dots1 dots2 . Rest)
            (and (zero? depth) (ellipsis? #'dots1) (ellipsis? #'dots2))
            (let f ([Exp #'(... ((Exp ...) ...))] [Rest #'Rest] [ndots 2])
              (syntax-case Rest ()
                [(dots . Rest)
                 (ellipsis? #'dots)
                 (with-syntax ([Exp Exp])
                   (f #'(... (Exp ...)) #'Rest (+ ndots 1)))]
                [Rest
                 (with-values (destruct Orig Exp depth)
                   (syntax-lambda (ExpBuilder (ExpVar ...) (ExpExp ...))
                                  (if (null? #'(ExpVar ...))
                                      (syntax-error Orig "Bad ellipsis")
                                      (with-values (destruct Orig #'Rest depth)
                                        (syntax-lambda (RestBuilder RestVars RestExps)
                                                       (values
                                                        #`(append
                                                           #,(let f ([ndots ndots])
                                                               (if (= ndots 1)
                                                                   #'ExpBuilder
                                                                   #`(apply append #,(f (- ndots 1)))))
                                                           RestBuilder)
                                                        (append #'(ExpVar ...) #'RestVars)
                                                        (append #'(ExpExp ...) #'RestExps)))))))])))
           ((quasiquote Exp)
            (with-values (destruct Orig #'Exp (add1 depth))
              (syntax-lambda (Builder Vars Exps)
                             (if (null? #'Vars)
                                 (values #''(quasiquote Exp) '() '())
                                 (values #'(list 'quasiquote Builder) #'Vars #'Exps)))))
           ;; unquote
           ((unquote Exp)
            (zero? depth)
            (with-temp X
                       (values #'X (list #'X) (list #'Exp))))
           ((unquote Exp)
            (with-values (destruct Orig #'Exp (sub1 depth))
              (syntax-lambda (Builder Vars Exps)
                             (if (null? #'Vars)
                                 (values #''(unquote Exp) '() '())
                                 (values #'(list 'unquote Builder) #'Vars #'Exps)))))
           ;; splicing
           (((unquote-splicing Exp))
            (zero? depth)
            (with-temp X
                       (values #'X (list #'X) (list #'Exp))))
           (((unquote-splicing Exp ...))
            (zero? depth)
            (with-temps (X ...) (Exp ...)
                        (values #'(append X ...) #'(X ...) #'(Exp ...))))
           (((unquote-splicing Exp ...) . Rest)
            (zero? depth)
            (with-values (destruct Orig #'Rest depth)
              (syntax-lambda (Builder Vars Exps)
                             (with-temps (X ...) (Exp ...)
                                         (if (null? #'Vars)
                                             (values #'(append X ... 'Rest)
                                                     #'(X ...) #'(Exp ...))
                                             (values #'(append X ... Builder)
                                                     #'(X ... . Vars) #'(Exp ... . Exps)))))))
           ((unquote-splicing Exp ...)
            (with-values (destruct Orig #'(Exp ...) (sub1 depth))
              (syntax-lambda (Builder Vars Exps)
                             (if (null? #'Vars)
                                 (values #''(unquote-splicing Exp ...) '() '())
                                 (values #'(cons 'unquote-splicing Builder)
                                         #'Vars #'Exps)))))
           ;; dots
           (((unquote Exp) Dots)
            (and (zero? depth) (ellipsis? #'Dots))
            (with-temp X
                       (values #'X (list #'X) (list #'Exp))))
           (((unquote Exp) Dots . Rest)
            (and (zero? depth) (ellipsis? #'Dots))
            (with-values (destruct Orig #'Rest depth)
              (syntax-lambda (RestBuilder RestVars RestExps)
                             (with-syntax ((TailExp
                                            (if (null? #'RestVars)
                                                #''Rest
                                                #'RestBuilder)))
                               (with-temp X
                                          (values #'(append X TailExp)
                                                  (cons #'X #'RestVars)
                                                  (cons #'Exp #'RestExps)))))))
           ((Exp Dots . Rest)
            (and (zero? depth) (ellipsis? #'Dots))
            (with-values (destruct Orig #'Exp depth)
              (syntax-lambda (ExpBuilder (ExpVar ...) (ExpExp ...))
                             (if (null? #'(ExpVar ...))
                                 (syntax-error Orig "Bad ellipsis")
                                 (with-values (destruct Orig #'Rest depth)
                                   (syntax-lambda (RestBuilder RestVars RestExps)
                                                  (with-syntax ((TailExp
                                                                 (if (null? #'RestVars)
                                                                     #''Rest
                                                                     #'RestBuilder))
                                                                (Orig Orig))
                                                    (values #'(let f ((ExpVar ExpVar) ...)
                                                                (if (and (pair? ExpVar) ...)
                                                                    (cons
                                                                     (let ((ExpVar (car ExpVar)) ...)
                                                                       ExpBuilder)
                                                                     (f (cdr ExpVar) ...))
                                                                    (if (and (null? ExpVar) ...)
                                                                        TailExp
                                                                        (error 'unquote
                                                                               "Mismatched lists in ~s"
                                                                               Orig))))
                                                            (append #'(ExpVar ...) #'RestVars)
                                                            (append #'(ExpExp ...) #'RestExps)))))))))
           ;; Vectors
           (#(X ...)
            (with-values (destruct Orig #'(X ...) depth)
              (syntax-lambda (LsBuilder LsVars LsExps)
                             (values #'(list->vector LsBuilder) #'LsVars #'LsExps))))
           ;; random stuff
           ((Hd . Tl)
            (with-values (destruct Orig #'Hd depth)
              (syntax-lambda (HdBuilder HdVars HdExps)
                             (with-values (destruct Orig #'Tl depth)
                               (syntax-lambda (TlBuilder TlVars TlExps)
                                              (with-syntax ((Hd (if (null? #'HdVars)
                                                                    #''Hd
                                                                    #'HdBuilder))
                                                            (Tl (if (null? #'TlVars)
                                                                    #''Tl
                                                                    #'TlBuilder)))
                                                (values #'(cons Hd Tl)
                                                        (append #'HdVars #'TlVars)
                                                        (append #'HdExps #'TlExps))))))))
           (OtherThing
            (values #''OtherThing '() '())))))
     ;; macro begins
     (syntax-case x ()
       ((_ Datum)
        (with-values (destruct #'(quasiquote Datum) #'Datum 0)
          (syntax-lambda (Builder (Var ...) (Exp ...))
                         (if (null? #'(Var ...))
                             #''Datum
                             #'(let ((Var Exp) ...)
                                 Builder))))))))

 (define-syntax extend-backquote
   (lambda (x)
     (syntax-case x ()
       [(_ Template Exp ...)
        (with-syntax ([quasiquote (datum->syntax #'Template 'quasiquote)])
          #'(let-syntax ([quasiquote
                          (lambda (x)
                            (syntax-case x ()
                              ((_ Foo) #'(my-backquote Foo))))])
              Exp ...))])))

 (define-syntax with-ellipsis-aware-quasiquote
   (lambda (x)
     (syntax-case x ()
       [(k b1 b2 ...)
        (with-implicit (k quasiquote)
                       #'(let-syntax ([quasiquote
                                       (lambda (x)
                                         (syntax-case x ()
                                           ((_ e) #'(my-backquote e))))])
                           (let () b1 b2 ...)))])))

;;; ------------------------------

 (define-syntax with-values
   (syntax-rules ()
     ((_ P C) (call-with-values (lambda () P) C))))

 (define-syntax letcc
   (syntax-rules ()
     ((_ V B0 B ...) (call/cc (lambda (V) B0 B ...)))))

 (define classify-list
   (lambda (ls)
     (cond
      ((null? ls) 'proper)
      ((not (pair? ls)) 'improper)
      (else
       (let f ((tortoise ls) (hare (cdr ls)))
         (cond
          ((eq? tortoise hare) 'infinite)
          ((null? hare) 'proper)
          ((not (pair? hare)) 'improper)
          (else
           (let ((hare (cdr hare)))
             (cond
              ((null? hare) 'proper)
              ((not (pair? hare)) 'improper)
              (else (f (cdr ls) (cdr hare))))))))))))

 (define ilist-copy-flat
   (lambda (ils)
     (let f ((tortoise ils) (hare (cdr ils)))
       (if (eq? tortoise hare)
           (list (car tortoise))
           (cons (car tortoise) (f (cdr tortoise) (cddr hare)))))))

 (define sexp-dispatch
   (lambda (obj pat);; #f or list of vars
     (letcc escape
            (let ((fail (lambda () (escape #f))))
              (let f ((pat pat) (obj obj) (vals '()))
                (cond
                 ((eq? pat 'any)
                  (cons obj vals))
                 ((eq? pat 'each-any)
                  ;; handle infinities
                  (case (classify-list obj)
                    ((proper infinite) (cons obj vals))
                    ((improper) (fail))))
                 ((pair? pat)
                  (if (pair? obj)
                      (f (car pat) (car obj) (f (cdr pat) (cdr obj) vals))
                      (fail)))
                 ((vector? pat)
                  (case (vector-ref pat 0)
                    ((atom)
                     (let ((a (vector-ref pat 1)))
                       (if (eqv? obj a)
                           vals
                           (fail))))
                    ((vector)
                     (if (vector? obj)
                         (let ((vec-pat (vector-ref pat 1)))
                           (f vec-pat (vector->list obj) vals))
                         (fail)))
                    ((each)
                     ;; if infinite, copy the list as flat, then do the matching,
                     ;; then do some set-cdrs.
                     (let ((each-pat (vector-ref pat 1))
                           (each-size (vector-ref pat 2)))
                       (case (classify-list obj)
                         ((improper) (fail))
                         ((infinite)
                          (let ((each-vals (f pat (ilist-copy-flat obj) '())))
                            (for-each (lambda (x) (set-cdr! (last-pair x) x))
                                      each-vals)
                            (append each-vals vals)))
                         ((proper)
                          (append
                           (let g ((obj obj))
                             (if (null? obj)
                                 (make-list each-size '())
                                 (let ((hd-vals (f each-pat (car obj) '()))
                                       (tl-vals (g (cdr obj))))
                                   (map cons hd-vals tl-vals))))
                           vals)))))
                    ((tail-each)
                     (let ((each-pat (vector-ref pat 1))
                           (each-size (vector-ref pat 2))
                           (revtail-pat (vector-ref pat 3))
                           (revtail-tail-pat (vector-ref pat 4)))
                       (when (eq? (classify-list obj) 'infinite) (fail))
                       (with-values
                           (let g ((obj obj))
                             ;; in-tail?, vals, revtail-left/ls
                             (cond
                              ((pair? obj)
                               (with-values (g (cdr obj))
                                 (lambda (in-tail? vals tail-left/ls)
                                   (if in-tail?
                                       (if (null? tail-left/ls)
                                           (values #f vals (list (car obj)))
                                           (values #t (f (car tail-left/ls)
                                                         (car obj)
                                                         vals)
                                                   (cdr tail-left/ls)))
                                       (values #f vals
                                               (cons (car obj) tail-left/ls))))))
                              (else
                               (values #t
                                       (f revtail-tail-pat obj vals)
                                       revtail-pat))))
                         (lambda (in-tail? vals tail-left/ls)
                           (if in-tail?
                               (if (null? tail-left/ls)
                                   (append (make-list each-size '())
                                           vals)
                                   (fail))
                               (f each-pat tail-left/ls vals))))))))
                 (else
                  (if (eqv? obj pat)
                      vals
                      (fail)))))))))
 )

#!eof

;;; examples of passing along threaded information.

;;; Try (collect-symbols '(if (x y 'a 'c zz) 'b 'c))
;;; Note that it commonizes the reference to c.

(define-syntax with-values
  (syntax-rules ()
    ((_ P C) (call-with-values (lambda () P) C))))
(define collect-symbols
  (lambda (exp)
    (with-values (collect-symbols-help exp)
................................................................................
        (match symbol-decls
          (((,symbol-name . ,symbol-var) ...)
           `(let ((,symbol-var (quote ,symbol-name)) ...) ,exp)))))))
(define collect-symbols-help
  (lambda (exp)
    (let ((symbol-env '()))
      (match+ (symbol-env) exp
              (,x
               (guard (symbol? x))
               (values symbol-env x))
              ((quote ,x)
               (guard (symbol? x))
               (let ((pair/false (assq x symbol-env)))
                 (if pair/false
                     (values symbol-env (cdr pair/false))
                     (let ((v (gensym)))
                       (values (cons (cons x v) symbol-env)
                               v)))))
              ((quote ,x)
               (values symbol-env `(quote ,x)))
              ((if ,[t] ,[c] ,[a])
               (values symbol-env `(if ,t ,c ,a)))
              ((,[op] ,[arg] ...)
               (values symbol-env `(,op ,arg ...)))))))

;;; the grammar for this one is just if-exprs and everything else

(define collect-leaves
  (lambda (exp acc)
    (match+ (acc) exp
            ((if ,[] ,[] ,[])
             acc)
            ((,[] ,[] ...)
             acc)
            (,x
             (cons x acc)))))

;; here's something that takes apart quoted stuff.

(define destruct
  (lambda (datum)
    (match datum
      (() `'())
      ((,[X] . ,[Y])`(cons ,X ,Y))
      (#(,[X] ...) `(vector ,X ...))
      (,thing
       (guard (symbol? thing))
       `',thing)
      (,thing
       thing))))

;; examples using explicit Catas

(define sumsquares
  (lambda (ls)
    (define square
      (lambda (x)
        (* x x)))
    (match ls
      [(,[a*] ...) (apply + a*)]
      [,[square -> n] n])))

(define sumsquares
  (lambda (ls)
    (define square
      (lambda (x)
        (* x x)))
    (let ([acc 0])
      (match+ (acc) ls
              [(,[] ...) acc]
              [,[(lambda (acc x) (+ acc (square x))) ->] acc]))))

;;; The following uses explicit Catas to parse programs in the
;;; simple language defined by the grammar below

;;; <Prog> -> (program <Stmt>* <Expr>)
;;; <Stmt> -> (if <Expr> <Stmt> <Stmt>)
;;;         | (set! <var> <Expr>)
................................................................................
;; 3
;; ;;
;; > (match '((1 2 3) 5 (1 2 3))
;;     [((,a ...) ,b (,a ...)) `(,a ... ,b)])
;; (1 2 3 5)
;; ;;
;; > (parameterize ([match-equality-test (lambda (x y) (equal? x (reverse y)))])
;;     (match '((1 2 3) (3 2 1))
;;       [(,a ,a) 'yes]
;;       [,oops 'no]))
;; yes

;; [10 Jan 2002]
;; eh fixed bug that caused (match '((1 2 3 4)) (((,a ... ,d) . ,x) a)) to
;; blow up.  The bug was caused by a bug in the sexp-dispatch procedure
................................................................................
;; [29 Feb 2000]
;; Fixed a case sensitivity bug.

;; [24 Feb 2000]
;; Matcher now handles vector patterns.  Quasiquote also handles
;; vector patterns, but does NOT do the csv6.2 optimization of
;; `#(a 1 ,(+ 3 4) x y) ==> (vector 'a 1 (+ 3 4) 'x 'y).
;; Also fixed bug in (P ... . P) matching code.

;; [23 Feb 2000]
;; KSM fixed bug in unquote-splicing inside quasiquote.

;; [10 Feb 2000]
;; New forms match+ and trace-match+ thread arguments right-to-left.
;; The pattern (P ... . P) now works the way you might expect.
;; Infinite lists are now properly matched (and not matched).
;; Removed the @ pattern.
;; Internal: No longer converting into syntax-case.

;; [6 Feb 2000]
;; Added expansion-time error message for referring to cata variable
;; in a guard.

;; [4 Feb 2000]
;; Fixed backquote so it can handle nested backquote (oops).
................................................................................
;;   `((unquote-splicing x y z) b) =expand==> (append x y z (list 'b))

;; [1 Feb 2000]
;; Fixed a bug involving forgetting to quote stuff in the revised backquote.
;; Recognized unquote-splicing and signalled errors in the appropriate places.
;; Added support for deep elipses in backquote.
;; Rewrote backquote so it does the rebuilding directly instead of
;; expanding into Chez's backquote.

;; [31 Jan 2000]
;; Kent Dybvig fixed template bug.

;; [31 Jan 2000]
;; Added the trace-match form, and made guards contain
;; an explicit and expression:
................................................................................

;; [26 Jan 2000]
;; Inside the clauses of match expressions, the following
;; transformation is performed inside backquote expressions:
;;    ,v ...      ==> ,@v
;;    (,v ,w) ... ==> ,@(map list v w)
;;    etc.

;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation files
;;; (the "Software"), to deal in the Software without restriction,
;;; including without limitation the rights to use, copy, modify, merge,
;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;; and to permit persons to whom the Software is furnished to do so,
;;; subject to the following conditions:
;;; 
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;; 
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;; SOFTWARE.

;;; This program was originally designed and implemented by Dan Friedman. 
;;; It was redesigned and reimplemented by Erik Hilsdale.  Additional
;;; modifications were made by Kent Dybvig, Steve Ganz, and Aziz Ghuloum.
;;; Parts of the implementation were adapted from the portable syntax-case
;;; implementation written by Kent Dybvig, Oscar Waddell, Bob Hieb, and
;;; Carl Bruggeman and is used by permission of Cadence Research Systems.

;;; A change log appears at end of this file.
................................................................................
;;         || ,[Cata -> Id*]
;;         || Id

;; Cata   ::= Exp

;; YOU'RE NOT ALLOWED TO REFER TO CATA VARS IN GUARDS. (reasonable!)

(module ((match+ match-help match-help1 clause-body let-values**
           guard-body convert-pat mapper my-backquote extend-backquote
           sexp-dispatch)
         (trace-match+ match-help match-help1 clause-body let-values**
           guard-body convert-pat mapper my-backquote extend-backquote
           sexp-dispatch)
         (match match-help match-help1 clause-body let-values**
           guard-body convert-pat mapper my-backquote extend-backquote
           sexp-dispatch)
         (trace-match match-help match-help1 clause-body let-values**
           guard-body convert-pat mapper my-backquote extend-backquote
           sexp-dispatch)
         (with-ellipsis-aware-quasiquote my-backquote)
         match-equality-test)

(import scheme)

(define match-equality-test
  (make-parameter
    equal?
    (lambda (x)
      (unless (procedure? x)
        (error 'match-equality-test "~s is not a procedure" x))
      x)))

(define-syntax match+
  (lambda (x)
    (syntax-case x ()
      [(k (ThreadedId ...) Exp Clause ...)
       #'(let f ((ThreadedId ThreadedId) ... (x Exp))
           (match-help k f x (ThreadedId ...) Clause ...))])))

(define-syntax match
  (lambda (x)
    (syntax-case x ()
      [(k Exp Clause ...)
       #'(let f ((x Exp))
           (match-help k f x () Clause ...))])))

(define-syntax trace-match+
  (lambda (x)
    (syntax-case x ()
      [(k (ThreadedId ...) Name Exp Clause ...)
       #'(letrec ((f (trace-lambda Name (ThreadedId ... x)
                       (match-help k f x (ThreadedId ...) Clause ...))))
           (f ThreadedId ... x))])))

(define-syntax trace-match
  (lambda (x)
    (syntax-case x ()
      [(k Name Exp Clause ...)
       #'(letrec ((f (trace-lambda Name (x)
                       (match-help k f x () Clause ...))))
           (f Exp))])))

;;; ------------------------------

(define-syntax let-values**
  (syntax-rules ()
    ((_ () B0 B ...) (begin B0 B ...))
    ((_ ((Formals Exp) Rest ...) B0 B ...)
     (let-values** (Rest ...) 
       (call-with-values (lambda () Exp)
         (lambda Formals B0 B ...))))))

(define-syntax match-help
  (lambda (x)
    (syntax-case x ()
      ((_ Template Cata Obj ThreadedIds)
       #'(error 'match "Unmatched datum: ~s" Obj))
      ((_ Template Cata Obj ThreadedIds (Pat B0 B ...) Rest ...)
       #'(convert-pat Pat
           (match-help1 Template Cata Obj ThreadedIds 
             (B0 B ...)
             Rest ...)))
      ((_ Template Cata Obj ThreadedIds cls Rest ...)
       (syntax-error #'cls "invalid match clause")))))
    

(define-syntax match-help1
  (lambda (x)
    (syntax-case x (guard)
      [(_ PatLit Vars () Cdecls Template Cata Obj ThreadedIds
         ((guard) B0 B ...) Rest ...)
       #'(let ((ls/false (sexp-dispatch Obj PatLit)))
           (if ls/false
               (apply (lambda Vars
                        (clause-body Cata Cdecls ThreadedIds
                          (extend-backquote Template B0 B ...)))
                 ls/false)
               (match-help Template Cata Obj ThreadedIds Rest ...)))]
      [(_ PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
         ((guard G ...) B0 B ...) Rest ...)
       #'(let ((ls/false (sexp-dispatch Obj PatLit)))
           (if (and ls/false (apply (lambda Vars
                                      (guard-body Cdecls
                                        (extend-backquote Template
                                          (and PG ... G ...))))
                               ls/false))
               (apply (lambda Vars
                        (clause-body Cata Cdecls ThreadedIds
                          (extend-backquote Template B0 B ...)))
                 ls/false)
               (match-help Template Cata Obj ThreadedIds Rest ...)))]
      [(_ PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
         (B0 B ...) Rest ...)
       #'(match-help1 PatLit Vars (PG ...) Cdecls Template Cata Obj ThreadedIds
           ((guard) B0 B ...) Rest ...)])))

(define-syntax clause-body
  (lambda (x)
    (define build-mapper
      (lambda (vars depth cata tIds)
        (if (zero? depth)
            cata
            (with-syntax ((rest (build-mapper vars (- depth 1) cata tIds))
                          (vars vars)
                          (tIds tIds))
              #'(mapper rest vars tIds)))))
    (syntax-case x ()
      ((_ Cata ((CVar CDepth CMyCata CFormal ...) ...) (ThreadedId ...) B)
       (with-syntax (((Mapper ...)
                      (map (lambda (mycata formals depth)
                             (build-mapper formals
                               (syntax->datum depth)
                               (syntax-case mycata ()
                                 [#f #'Cata]
                                 [exp #'exp])
                               #'(ThreadedId ...)))
                        #'(CMyCata ...)
                        #'((CFormal ...) ...)
                        #'(CDepth ...))))
         #'(let-values** (([ThreadedId ... CFormal ...]
                           (Mapper ThreadedId ... CVar))
                          ...)
             B))))))

(define-syntax guard-body
  (lambda (x)
    (syntax-case x ()
      ((_ ((Cvar Cdepth MyCata Cformal ...) ...) B)
       (with-syntax (((CF ...) (apply append #'((Cformal ...) ...))))
         #'(let-syntax
               ((CF
                  (lambda (x)
                    (syntax-case x ()
                      (Name
                        (syntax-error #'Name
                          "guard cannot refer to return-value variable")))))
                ...)
             B))))))

(define-syntax convert-pat
  ;; returns sexp-pat x vars x guards x cdecls
  (let ()
    (define ellipsis?
      (lambda (x)
        (and (identifier? x) (free-identifier=? x #'(... ...)))))
    (define Var?
      (lambda (x)
        (syntax-case x (->)
          [-> #f]
          [id (identifier? #'id)])))
    (define fVar
      (lambda (var vars guards)
        (let loop ([ls vars])
          (if (null? ls)
              (values (cons var vars) guards)
              (if (bound-identifier=? var (car ls))
                  (with-syntax ([(tmp) (generate-temporaries (list var))]
                                [var (car ls)])
                    (values (cons #'tmp vars)
                            (cons #'((match-equality-test) tmp var) guards)))
                  (loop (cdr ls)))))))
    (define (f syn vars guards cdecls depth)
      (syntax-case syn (unquote)
        ((unquote . stuff) ; separate for better error detection
         (syntax-case syn (unquote ->)
           ((unquote [MyCata -> Var ...])
            (andmap Var? #'(Var ...))
            (with-syntax (((Temp) (generate-temporaries '(x)))
                          (Depth depth))
              (values #'any
                      (cons #'Temp vars)
                      guards
                      (cons #'[Temp Depth MyCata Var ...] cdecls))))
           ((unquote [Var ...])
            (andmap Var? #'(Var ...))
            (with-syntax (((Temp) (generate-temporaries '(x)))
                          (Depth depth))
              (values #'any
                      (cons #'Temp vars)
                      guards
                      (cons #'[Temp Depth #f Var ...] cdecls))))
           ((unquote Var)
            (Var? #'Var)
            (let-synvalues* ([(vars guards) (fVar #'Var vars guards)])
              (values #'any #'vars #'guards cdecls)))))
        (((unquote . stuff) Dots)
         (ellipsis? #'Dots)
         (syntax-case syn (unquote ->)
           (((unquote [MyCata -> Var ...]) Dots)
            (andmap Var? #'(Var ...))
            (with-syntax (((Temp) (generate-temporaries '(x)))
                          (Depth+1 (add1 depth)))
              (values #'each-any
                      (cons #'Temp vars)
                      guards
                      (cons #'[Temp Depth+1 MyCata Var ...] cdecls))))
           (((unquote [Var ...]) Dots)
            (andmap Var? #'(Var ...))
            (with-syntax (((Temp) (generate-temporaries '(x)))
                          (Depth+1 (add1 depth)))
              (values #'each-any
                      (cons #'Temp vars)
                      guards
                      (cons #'[Temp Depth+1 #f Var ...] cdecls))))
           (((unquote Var) Dots)
            (Var? #'Var)
            (let-synvalues* ([(vars guards) (fVar #'Var vars guards)])
              (values #'each-any #'vars #'guards cdecls)))
           ((expr Dots) (syntax-error #'expr "match-pattern unquote syntax"))))
        ((Pat Dots)
         (ellipsis? #'Dots)
         (let-synvalues* (((Dpat Dvars Dguards Dcdecls)
                           (f #'Pat vars guards cdecls (add1 depth))))
           (with-syntax ((Size (- (length #'Dvars) (length vars))))
             (values #'#(each Dpat Size) #'Dvars #'Dguards #'Dcdecls))))
        ((Pat Dots . Rest)
         (ellipsis? #'Dots)
         (let-synvalues* (((Rpat Rvars Rguards Rcdecls)
                           (f #'Rest vars guards cdecls depth))
                          ((Dpat Dvars Dguards Dcdecls)
                           (f #'(Pat (... ...)) #'Rvars #'Rguards #'Rcdecls
                             depth)))
           (with-syntax ((Size (- (length #'Dvars) (length #'Rvars)))
                         ((RevRestTl . RevRest) (reverseX #'Rpat '())))
             (values #'#(tail-each Dpat Size RevRest RevRestTl)
                     #'Dvars #'Dguards #'Dcdecls))))
        ((X . Y)
         (let-synvalues* (((Ypat Yvars Yguards Ycdecls)
                           (f #'Y vars guards cdecls depth))
                          ((Xpat Xvars Xguards Xcdecls)
                           (f #'X #'Yvars #'Yguards #'Ycdecls depth)))
           (values #'(Xpat . Ypat) #'Xvars #'Xguards #'Xcdecls)))
        (() (values #'() vars guards cdecls))
        (#(X ...)
         (let-synvalues* (((Pat Vars Eqvars Cdecls)
                           (f #'(X ...) vars guards cdecls depth)))
           (values #'#(vector Pat) #'Vars #'Eqvars #'Cdecls)))
        (Thing (values #'#(atom Thing) vars guards cdecls))))
    (define reverseX
      (lambda (ls acc)
        (if (pair? ls)
            (reverseX (cdr ls) (cons (car ls) acc))
            (cons ls acc))))
    (define-syntax let-synvalues*
      (syntax-rules ()
        ((_ () B0 B ...) (begin B0 B ...))
        ((_ (((Formal ...) Exp) Decl ...) B0 B ...)
         (call-with-values (lambda () Exp)
           (lambda (Formal ...)
             (with-syntax ((Formal Formal) ...)
               (let-synvalues* (Decl ...) B0 B ...)))))))
    (lambda (syn) 
      (syntax-case syn ()
        ((_ syn (kh . kt))
         (let-synvalues* (((Pat Vars Guards Cdecls) (f #'syn '() '() '() 0)))
           #'(kh 'Pat Vars Guards Cdecls . kt)))))))

(define-syntax mapper
  (lambda (x)
    (syntax-case x ()
      ((_ F (RetId ...) (ThreadId ...))
       (with-syntax (((t ...) (generate-temporaries #'(RetId ...)))
                     ((ts ...) (generate-temporaries #'(RetId ...)))
                     ((null ...) (map (lambda (x) #''()) #'(RetId ...))))
         #'(let ((fun F))
             (rec g
               (lambda (ThreadId ... ls)
                 (if (null? ls)
                     (values ThreadId ... null ...)
                     (call-with-values
                         (lambda () (g ThreadId ... (cdr ls)))
                       (lambda (ThreadId ... ts ...)
                         (call-with-values
                             (lambda () (fun ThreadId ... (car ls)))
                           (lambda (ThreadId ... t ...)
                             (values ThreadId ... (cons t ts) ...))))))))))))))

;;; ------------------------------

(define-syntax my-backquote
  (lambda (x)
    (define ellipsis?
      (lambda (x)
        (and (identifier? x) (free-identifier=? x #'(... ...)))))
    (define-syntax with-values
      (syntax-rules ()
        ((_ P C) (call-with-values (lambda () P) C))))
    (define-syntax syntax-lambda
      (lambda (x)
        (syntax-case x ()
          ((_ (Pat ...) Body0 Body ...)
           (with-syntax (((X ...) (generate-temporaries #'(Pat ...))))
             #'(lambda (X ...)
                 (with-syntax ((Pat X) ...)
                   Body0 Body ...)))))))
    (define-syntax with-temp
      (syntax-rules ()
        ((_ V Body0 Body ...)
         (with-syntax (((V) (generate-temporaries '(x))))
           Body0 Body ...))))
    (define-syntax with-temps
      (syntax-rules ()
        ((_ (V ...) (Exp ...) Body0 Body ...)
         (with-syntax (((V ...) (generate-temporaries #'(Exp ...))))
           Body0 Body ...))))
    (define destruct
      (lambda (Orig x depth)
        (syntax-case x (quasiquote unquote unquote-splicing)
          ;; inner quasiquote
          ((Exp dots1 dots2 . Rest)
           (and (zero? depth) (ellipsis? #'dots1) (ellipsis? #'dots2))
           (let f ([Exp #'(... ((Exp ...) ...))] [Rest #'Rest] [ndots 2])
             (syntax-case Rest ()
               [(dots . Rest)
                (ellipsis? #'dots)
                (with-syntax ([Exp Exp])
                  (f #'(... (Exp ...)) #'Rest (+ ndots 1)))]
               [Rest
                (with-values (destruct Orig Exp depth)
                  (syntax-lambda (ExpBuilder (ExpVar ...) (ExpExp ...))
                    (if (null? #'(ExpVar ...))
                        (syntax-error Orig "Bad ellipsis")
                        (with-values (destruct Orig #'Rest depth)
                          (syntax-lambda (RestBuilder RestVars RestExps)
                            (values
                              #`(append
                                  #,(let f ([ndots ndots])
                                      (if (= ndots 1)
                                          #'ExpBuilder
                                          #`(apply append #,(f (- ndots 1)))))
                                  RestBuilder)
                              (append #'(ExpVar ...) #'RestVars)
                              (append #'(ExpExp ...) #'RestExps)))))))])))
          ((quasiquote Exp)
           (with-values (destruct Orig #'Exp (add1 depth))
             (syntax-lambda (Builder Vars Exps)
               (if (null? #'Vars)
                   (values #''(quasiquote Exp) '() '())
                   (values #'(list 'quasiquote Builder) #'Vars #'Exps)))))
          ;; unquote
          ((unquote Exp)
           (zero? depth)
           (with-temp X
             (values #'X (list #'X) (list #'Exp))))
          ((unquote Exp)
           (with-values (destruct Orig #'Exp (sub1 depth))
             (syntax-lambda (Builder Vars Exps)
               (if (null? #'Vars)
                   (values #''(unquote Exp) '() '())
                   (values #'(list 'unquote Builder) #'Vars #'Exps)))))
          ;; splicing
          (((unquote-splicing Exp))
           (zero? depth)
           (with-temp X
             (values #'X (list #'X) (list #'Exp))))
          (((unquote-splicing Exp ...))
           (zero? depth)
           (with-temps (X ...) (Exp ...)
             (values #'(append X ...) #'(X ...) #'(Exp ...))))
          (((unquote-splicing Exp ...) . Rest)
           (zero? depth)
           (with-values (destruct Orig #'Rest depth)
             (syntax-lambda (Builder Vars Exps)
               (with-temps (X ...) (Exp ...)
                 (if (null? #'Vars)
                     (values #'(append X ... 'Rest)
                             #'(X ...) #'(Exp ...))
                     (values #'(append X ... Builder)
                             #'(X ... . Vars) #'(Exp ... . Exps)))))))
          ((unquote-splicing Exp ...)
           (with-values (destruct Orig #'(Exp ...) (sub1 depth))
             (syntax-lambda (Builder Vars Exps)
               (if (null? #'Vars)
                   (values #''(unquote-splicing Exp ...) '() '())
                   (values #'(cons 'unquote-splicing Builder)
                           #'Vars #'Exps)))))
          ;; dots
          (((unquote Exp) Dots)
           (and (zero? depth) (ellipsis? #'Dots))
           (with-temp X
             (values #'X (list #'X) (list #'Exp))))
          (((unquote Exp) Dots . Rest)
           (and (zero? depth) (ellipsis? #'Dots))
           (with-values (destruct Orig #'Rest depth)
             (syntax-lambda (RestBuilder RestVars RestExps)
               (with-syntax ((TailExp
                               (if (null? #'RestVars)
                                   #''Rest
                                   #'RestBuilder)))
                 (with-temp X
                   (values #'(append X TailExp)
                           (cons #'X #'RestVars)
                           (cons #'Exp #'RestExps)))))))
          ((Exp Dots . Rest)
           (and (zero? depth) (ellipsis? #'Dots))
           (with-values (destruct Orig #'Exp depth)
             (syntax-lambda (ExpBuilder (ExpVar ...) (ExpExp ...))
               (if (null? #'(ExpVar ...))
                   (syntax-error Orig "Bad ellipsis")
                   (with-values (destruct Orig #'Rest depth)
                     (syntax-lambda (RestBuilder RestVars RestExps)
                       (with-syntax ((TailExp
                                       (if (null? #'RestVars)
                                           #''Rest
                                           #'RestBuilder))
                                     (Orig Orig))
                         (values #'(let f ((ExpVar ExpVar) ...)
                                     (if (and (pair? ExpVar) ...)
                                         (cons
                                           (let ((ExpVar (car ExpVar)) ...)
                                             ExpBuilder)
                                           (f (cdr ExpVar) ...))
                                         (if (and (null? ExpVar) ...)
                                             TailExp
                                             (error 'unquote
                                               "Mismatched lists in ~s"
                                               Orig))))
                                 (append #'(ExpVar ...) #'RestVars)
                                 (append #'(ExpExp ...) #'RestExps)))))))))
          ;; Vectors
          (#(X ...)
           (with-values (destruct Orig #'(X ...) depth)
             (syntax-lambda (LsBuilder LsVars LsExps)
               (values #'(list->vector LsBuilder) #'LsVars #'LsExps))))
          ;; random stuff
          ((Hd . Tl)
           (with-values (destruct Orig #'Hd depth)
             (syntax-lambda (HdBuilder HdVars HdExps)
               (with-values (destruct Orig #'Tl depth)
                 (syntax-lambda (TlBuilder TlVars TlExps)
                   (with-syntax ((Hd (if (null? #'HdVars)
                                         #''Hd
                                         #'HdBuilder))
                                 (Tl (if (null? #'TlVars)
                                         #''Tl
                                         #'TlBuilder)))
                     (values #'(cons Hd Tl)
                             (append #'HdVars #'TlVars)
                             (append #'HdExps #'TlExps))))))))
          (OtherThing
            (values #''OtherThing '() '())))))
    ;; macro begins
    (syntax-case x ()
      ((_ Datum)
       (with-values (destruct #'(quasiquote Datum) #'Datum 0)
         (syntax-lambda (Builder (Var ...) (Exp ...))
           (if (null? #'(Var ...))
               #''Datum
               #'(let ((Var Exp) ...)
                   Builder))))))))

(define-syntax extend-backquote
  (lambda (x)
    (syntax-case x ()
      [(_ Template Exp ...)
       (with-syntax ([quasiquote (datum->syntax #'Template 'quasiquote)])
         #'(let-syntax ([quasiquote


                          (lambda (x)
                            (syntax-case x ()
                              ((_ Foo) #'(my-backquote Foo))))])
             Exp ...))])))

(define-syntax with-ellipsis-aware-quasiquote
  (lambda (x)
    (syntax-case x ()
      [(k b1 b2 ...)
       (with-implicit (k quasiquote)
         #'(let-syntax ([quasiquote
                          (lambda (x)
                            (syntax-case x ()
                              ((_ e) #'(my-backquote e))))])
             (let () b1 b2 ...)))])))

;;; ------------------------------

(define-syntax with-values
  (syntax-rules ()
    ((_ P C) (call-with-values (lambda () P) C))))

(define-syntax letcc
  (syntax-rules ()
    ((_ V B0 B ...) (call/cc (lambda (V) B0 B ...)))))

(define classify-list
  (lambda (ls)
    (cond
      ((null? ls) 'proper)
      ((not (pair? ls)) 'improper)
      (else
        (let f ((tortoise ls) (hare (cdr ls)))
          (cond
            ((eq? tortoise hare) 'infinite)
            ((null? hare) 'proper)
            ((not (pair? hare)) 'improper)
            (else
              (let ((hare (cdr hare)))
                (cond
                  ((null? hare) 'proper)
                  ((not (pair? hare)) 'improper)
                  (else (f (cdr ls) (cdr hare))))))))))))

(define ilist-copy-flat
  (lambda (ils)
    (let f ((tortoise ils) (hare (cdr ils)))
      (if (eq? tortoise hare)
          (list (car tortoise))
          (cons (car tortoise) (f (cdr tortoise) (cddr hare)))))))

(define sexp-dispatch
  (lambda (obj pat);; #f or list of vars
    (letcc escape
      (let ((fail (lambda () (escape #f))))
        (let f ((pat pat) (obj obj) (vals '()))
          (cond
            ((eq? pat 'any)
             (cons obj vals))
            ((eq? pat 'each-any)
             ;; handle infinities
             (case (classify-list obj)
               ((proper infinite) (cons obj vals))
               ((improper) (fail))))
            ((pair? pat)
             (if (pair? obj)
                 (f (car pat) (car obj) (f (cdr pat) (cdr obj) vals))
                 (fail)))
            ((vector? pat)
             (case (vector-ref pat 0)
               ((atom)
                (let ((a (vector-ref pat 1)))
                  (if (eqv? obj a)
                      vals
                      (fail))))
               ((vector)
                (if (vector? obj)
                    (let ((vec-pat (vector-ref pat 1)))
                      (f vec-pat (vector->list obj) vals))
                    (fail)))
               ((each)
                ;; if infinite, copy the list as flat, then do the matching,
                ;; then do some set-cdrs. 
                (let ((each-pat (vector-ref pat 1))
                      (each-size (vector-ref pat 2)))
                  (case (classify-list obj)
                    ((improper) (fail))
                    ((infinite)
                     (let ((each-vals (f pat (ilist-copy-flat obj) '())))
                       (for-each (lambda (x) (set-cdr! (last-pair x) x))
                         each-vals)
                       (append each-vals vals)))
                    ((proper)
                     (append
                       (let g ((obj obj))
                         (if (null? obj)
                             (make-list each-size '())
                             (let ((hd-vals (f each-pat (car obj) '()))
                                   (tl-vals (g (cdr obj))))
                               (map cons hd-vals tl-vals))))
                       vals)))))
               ((tail-each)
                (let ((each-pat (vector-ref pat 1))
                      (each-size (vector-ref pat 2))
                      (revtail-pat (vector-ref pat 3))
                      (revtail-tail-pat (vector-ref pat 4)))
                  (when (eq? (classify-list obj) 'infinite) (fail))
                  (with-values
                      (let g ((obj obj))
                        ;; in-tail?, vals, revtail-left/ls
                        (cond
                          ((pair? obj)
                           (with-values (g (cdr obj))
                             (lambda (in-tail? vals tail-left/ls)
                               (if in-tail?
                                   (if (null? tail-left/ls)
                                       (values #f vals (list (car obj)))
                                       (values #t (f (car tail-left/ls)
                                                    (car obj)
                                                    vals)
                                               (cdr tail-left/ls)))
                                   (values #f vals
                                           (cons (car obj) tail-left/ls))))))
                          (else
                            (values #t
                                    (f revtail-tail-pat obj vals)
                                    revtail-pat))))
                    (lambda (in-tail? vals tail-left/ls)
                      (if in-tail?
                          (if (null? tail-left/ls)
                              (append (make-list each-size '())
                                vals)
                              (fail))
                          (f each-pat tail-left/ls vals))))))))
            (else
              (if (eqv? obj pat)
                  vals
                  (fail)))))))))
)

#!eof

;;; examples of passing along threaded information.

;;; Try (collect-symbols '(if (x y 'a 'c zz) 'b 'c))
;;; Note that it commonizes the reference to c. 

(define-syntax with-values
  (syntax-rules ()
    ((_ P C) (call-with-values (lambda () P) C))))
(define collect-symbols
  (lambda (exp)
    (with-values (collect-symbols-help exp)
................................................................................
        (match symbol-decls
          (((,symbol-name . ,symbol-var) ...)
           `(let ((,symbol-var (quote ,symbol-name)) ...) ,exp)))))))
(define collect-symbols-help
  (lambda (exp)
    (let ((symbol-env '()))
      (match+ (symbol-env) exp
        (,x
          (guard (symbol? x))
          (values symbol-env x))
        ((quote ,x)
         (guard (symbol? x))
         (let ((pair/false (assq x symbol-env)))
           (if pair/false
               (values symbol-env (cdr pair/false))
               (let ((v (gensym)))
                 (values (cons (cons x v) symbol-env)
                         v)))))
        ((quote ,x)
         (values symbol-env `(quote ,x)))
        ((if ,[t] ,[c] ,[a])
         (values symbol-env `(if ,t ,c ,a)))
        ((,[op] ,[arg] ...)
         (values symbol-env `(,op ,arg ...)))))))

;;; the grammar for this one is just if-exprs and everything else

(define collect-leaves
  (lambda (exp acc)
    (match+ (acc) exp
      ((if ,[] ,[] ,[])
       acc)
      ((,[] ,[] ...)
       acc)
      (,x
        (cons x acc)))))

;; here's something that takes apart quoted stuff. 

(define destruct
  (lambda (datum)
    (match datum
      (() `'())
      ((,[X] . ,[Y])`(cons ,X ,Y))
      (#(,[X] ...) `(vector ,X ...))
      (,thing
        (guard (symbol? thing))
        `',thing)
      (,thing
        thing))))

;; examples using explicit Catas

(define sumsquares
  (lambda (ls)
    (define square 
      (lambda (x)
        (* x x)))
    (match ls 
      [(,[a*] ...) (apply + a*)]
      [,[square -> n] n])))

(define sumsquares
  (lambda (ls)
    (define square 
      (lambda (x)
        (* x x)))
    (let ([acc 0])
      (match+ (acc) ls 
        [(,[] ...) acc]
        [,[(lambda (acc x) (+ acc (square x))) ->] acc]))))

;;; The following uses explicit Catas to parse programs in the
;;; simple language defined by the grammar below

;;; <Prog> -> (program <Stmt>* <Expr>)
;;; <Stmt> -> (if <Expr> <Stmt> <Stmt>)
;;;         | (set! <var> <Expr>)
................................................................................
;; 3
;; ;;
;; > (match '((1 2 3) 5 (1 2 3))
;;     [((,a ...) ,b (,a ...)) `(,a ... ,b)])
;; (1 2 3 5)
;; ;;
;; > (parameterize ([match-equality-test (lambda (x y) (equal? x (reverse y)))])
;;     (match '((1 2 3) (3 2 1))   
;;       [(,a ,a) 'yes]
;;       [,oops 'no]))
;; yes

;; [10 Jan 2002]
;; eh fixed bug that caused (match '((1 2 3 4)) (((,a ... ,d) . ,x) a)) to
;; blow up.  The bug was caused by a bug in the sexp-dispatch procedure
................................................................................
;; [29 Feb 2000]
;; Fixed a case sensitivity bug.

;; [24 Feb 2000]
;; Matcher now handles vector patterns.  Quasiquote also handles
;; vector patterns, but does NOT do the csv6.2 optimization of
;; `#(a 1 ,(+ 3 4) x y) ==> (vector 'a 1 (+ 3 4) 'x 'y).
;; Also fixed bug in (P ... . P) matching code. 

;; [23 Feb 2000]
;; KSM fixed bug in unquote-splicing inside quasiquote.

;; [10 Feb 2000]
;; New forms match+ and trace-match+ thread arguments right-to-left.
;; The pattern (P ... . P) now works the way you might expect.
;; Infinite lists are now properly matched (and not matched).
;; Removed the @ pattern.
;; Internal: No longer converting into syntax-case. 

;; [6 Feb 2000]
;; Added expansion-time error message for referring to cata variable
;; in a guard.

;; [4 Feb 2000]
;; Fixed backquote so it can handle nested backquote (oops).
................................................................................
;;   `((unquote-splicing x y z) b) =expand==> (append x y z (list 'b))

;; [1 Feb 2000]
;; Fixed a bug involving forgetting to quote stuff in the revised backquote.
;; Recognized unquote-splicing and signalled errors in the appropriate places.
;; Added support for deep elipses in backquote.
;; Rewrote backquote so it does the rebuilding directly instead of
;; expanding into Chez's backquote. 

;; [31 Jan 2000]
;; Kent Dybvig fixed template bug.

;; [31 Jan 2000]
;; Added the trace-match form, and made guards contain
;; an explicit and expression:
................................................................................

;; [26 Jan 2000]
;; Inside the clauses of match expressions, the following
;; transformation is performed inside backquote expressions:
;;    ,v ...      ==> ,@v
;;    (,v ,w) ... ==> ,@(map list v w)
;;    etc.

#!r6rs
(library 
 (nanomsg) 
 (export 
  nanomsg-library-init
  nn-errno nn-strerror  nn-bind nn-send nn-recv nn-connect nn-poll nn-close
  nn-socket nn-assert nn-shutdown nn-freemsg nn-recvmsg nn-sendmsg

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

#!r6rs
(library 
 (nanomsg) 
 (export 
  nanomsg-library-init
  nn-errno nn-strerror  nn-bind nn-send nn-recv nn-connect nn-poll nn-close
  nn-socket nn-assert nn-shutdown nn-freemsg nn-recvmsg nn-sendmsg

#! /usr/bin/env scheme-script
; -*- mode: scheme -*-















;
; example of remote REPL
; you can use any transport, tcp:// ipc:// websocket inproc
; see http://nanomsg.org/v1.0.0/nanomsg.7.html
; and nanomsg.sls for details
;
; ./local-repl tcp://127.0.0.1:12345

#! /usr/bin/env scheme-script
;; -*- mode: scheme -*-
;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

;
; example of remote REPL
; you can use any transport, tcp:// ipc:// websocket inproc
; see http://nanomsg.org/v1.0.0/nanomsg.7.html
; and nanomsg.sls for details
;
; ./local-repl tcp://127.0.0.1:12345

#! /usr/bin/env scheme-script
; -*- mode: scheme -*-















; example of remote REPL
; you can use any transport, tcp:// ipc:// websocket inproc
; see http://nanomsg.org/v1.0.0/nanomsg.7.html
; and nanomsg.sls for details
;
; ./local-repl tcp://127.0.0.1:12345
; ABC
................................................................................

(define sock (nn-socket AF_SP NN_REQ))
(define eid (nn-connect sock (car argv)))

(call/cc 
 (lambda (return)
   (let loop ()





     (printf "> ")
     (nn-send sock (string->utf8 
		    (call-with-string-output-port
		     (lambda (p)
		       (let ([token (read)])
			 (if (eof-object? token)
			     (return #f)
			     (write token p)))))) 0)
     (let ([buf (box #t)])
       (nn-recv sock buf NN_MSG 0)
       (printf "~d" (utf8->string (unbox buf))))

     (loop))))

#! /usr/bin/env scheme-script
;; -*- mode: scheme -*-
;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

; example of remote REPL
; you can use any transport, tcp:// ipc:// websocket inproc
; see http://nanomsg.org/v1.0.0/nanomsg.7.html
; and nanomsg.sls for details
;
; ./local-repl tcp://127.0.0.1:12345
; ABC
................................................................................

(define sock (nn-socket AF_SP NN_REQ))
(define eid (nn-connect sock (car argv)))

(call/cc 
 (lambda (return)
   (let loop ()
     (guard 
      (e (else (printf "error in remote-repl: on ~d: ~d with irritants ~d~n" 
							 (if (who-condition? e) (condition-who e) 'unknown)
							 (if (message-condition? e) (condition-message e) "")
							 (if (irritants-condition? e) (condition-irritants e) ""))))
      (printf "> ")
      (nn-send sock (string->utf8 
		     (call-with-string-output-port
		      (lambda (p)
			(let ([token (read)])
			  (if (eof-object? token)
			      (return #f)
			      (write token p)))))) 0)
      (let ([buf (box #t)])
	(nn-recv sock buf NN_MSG 0)
	(let ([s (utf8->string (unbox buf))])
	  (printf "~d" (if (string=? "#<void>\n" s) "" s)))))
     (loop))))

#!r6rs

(library
 (sdl2)
 (export sdl-library-init sdl-initialization sdl-initialization-everything
	 sdl-init sdl-init-sub-system sdl-quit-sub-system sdl-was-init sdl-quit
................................................................................
	  sdl-message-box-color-type-t
	  sdl-message-box-button-data-t
	  sdl-message-box-color-t
	  sdl-message-box-color-scheme-t
	  sdl-message-box-data-t

	  ;;MOUSE
	  sdl-get-mouse-focus
	 sdl-get-mouse-state

	 sdl-get-relative-mouse-state
	 sdl-warp-mouse-in-window

	 sdl-set-relative-mouse-mode

	 sdl-get-relative-mouse-mode

	 sdl-create-cursor
	 sdl-create-color-cursor
	 sdl-create-system-cursor
	 sdl-set-cursor
	 sdl-get-cursor
	 sdl-get-default-cursor
	 sdl-free-cursor
................................................................................
	 ;;ASSERT
	 sdl-report-assertion
	 sdl-set-assertion-handler
	 sdl-get-default-assertion-handler
	 sdl-get-assertion-handler
	 sdl-get-assertion-report
	 sdl-reset-assertion-report







	 )

 (import (chezscheme) 
	 (ffi-utils)
	 (only (srfi s1 lists) fold)
	 (only (thunder-utils) string-replace string-split) 
	 (only (srfi s13 strings) string-delete string-suffix? string-prefix?)
................................................................................

 (include "sdl2/main-functions.ss") 

 (include "sdl2/sdl-functions.ss")

 (include "sdl2/init.ss")


)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

#!r6rs

(library
 (sdl2)
 (export sdl-library-init sdl-initialization sdl-initialization-everything
	 sdl-init sdl-init-sub-system sdl-quit-sub-system sdl-was-init sdl-quit
................................................................................
	  sdl-message-box-color-type-t
	  sdl-message-box-button-data-t
	  sdl-message-box-color-t
	  sdl-message-box-color-scheme-t
	  sdl-message-box-data-t

	  ;;MOUSE
	 sdl-get-mouse-focus
	 sdl-get-mouse-state
         sdl-get-global-mouse-state
	 sdl-get-relative-mouse-state
	 sdl-warp-mouse-in-window
	 sdl-warp-mouse-global
	 sdl-set-relative-mouse-mode
	 sdl-capture-mouse
	 sdl-get-relative-mouse-mode
	 
	 sdl-create-cursor
	 sdl-create-color-cursor
	 sdl-create-system-cursor
	 sdl-set-cursor
	 sdl-get-cursor
	 sdl-get-default-cursor
	 sdl-free-cursor
................................................................................
	 ;;ASSERT
	 sdl-report-assertion
	 sdl-set-assertion-handler
	 sdl-get-default-assertion-handler
	 sdl-get-assertion-handler
	 sdl-get-assertion-report
	 sdl-reset-assertion-report

	 ;;EXTRAS

	 event-keyboard-keysym-sym
	 event-mouse-button
	 char-array
	 char*-array->string
	 )

 (import (chezscheme) 
	 (ffi-utils)
	 (only (srfi s1 lists) fold)
	 (only (thunder-utils) string-replace string-split) 
	 (only (srfi s13 strings) string-delete string-suffix? string-prefix?)
................................................................................

 (include "sdl2/main-functions.ss") 

 (include "sdl2/sdl-functions.ss")

 (include "sdl2/init.ss")

 (include "sdl2/extras.ss")
)

(define-sdl-func sdl-assert-state-t sdl-report-assertion ((data (* sdl-assert-data-t)) (a string) (b string) (c int)) "SDL_ReportAssertion")
(define-sdl-func void sdl-set-assertion-handler ((handler sdl-assertion-handler-t) (userdata void*)) "SDL_SetAssertionHandler")
(define-sdl-func sdl-assertion-handler-t sdl-get-default-assertion-handler () "SDL_GetDefaultAssertionHandler")
(define-sdl-func sdl-assertion-handler-t sdl-get-assertion-handler ((puserdata (* void*))) "SDL_GetAssertionHandler")
(define-sdl-func (* sdl-assert-data-t) sdl-get-assertion-report () "SDL_GetAssertionReport")
(define-sdl-func void sdl-reset-assertion-report () "SDL_ResetAssertionReport")

(define-sdl-func sdl-assert-state-t sdl-report-assertion ((arg-0 (* sdl-assert-data-t)) (arg-1 string) (arg-2 string) (arg-3 int)) "SDL_ReportAssertion")
(define-sdl-func void sdl-set-assertion-handler ((handler sdl-assertion-handler-t) (userdata void*)) "SDL_SetAssertionHandler")
(define-sdl-func sdl-assertion-handler-t sdl-get-default-assertion-handler () "SDL_GetDefaultAssertionHandler")
(define-sdl-func sdl-assertion-handler-t sdl-get-assertion-handler ((puserdata (* void*))) "SDL_GetAssertionHandler")
(define-sdl-func (* sdl-assert-data-t) sdl-get-assertion-report () "SDL_GetAssertionReport")
(define-sdl-func void sdl-reset-assertion-report () "SDL_ResetAssertionReport")

 (define-enumeration* sdl-assert-state
   (retry break abort ignore always-ignore))

 (define-ftype sdl-assert-data-t
   (struct 
    (always-ignore int)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-enumeration* sdl-assert-state
   (retry break abort ignore always-ignore))

 (define-ftype sdl-assert-data-t
   (struct 
    (always-ignore int)

 (define-ftype sdl-spin-lock-t int)
 (define-ftype sdl-atomic-t int)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-spin-lock-t int)
 (define-ftype sdl-atomic-t int)

(define-sdl-func void sdl-pause-audio-device ((dev sdl-audio-device-id-t) (pause_on int)) "SDL_PauseAudioDevice")
(define-sdl-func (* sdl-audio-spec-t) sdl-load-wav-rw ((src (* sdl-rw-ops-t)) (freesrc int) (spec (* sdl-audio-spec-t)) (audio_buf (* uint8)) (audio_len (* uint32))) "SDL_LoadWAV_RW")
(define-sdl-func void sdl-free-wav ((audio_buf (* uint8))) "SDL_FreeWAV")
(define-sdl-func int sdl-build-audio-cvt ((cvt (* sdl-audio-cvt-t)) (src_format sdl-audio-format-t) (src_channels uint8) (src_rate int) (dst_format sdl-audio-format-t) (dst_channels uint8) (dst_rate int)) "SDL_BuildAudioCVT")
(define-sdl-func int sdl-convert-audio ((cvt (* sdl-audio-cvt-t))) "SDL_ConvertAudio")
(define-sdl-func void sdl-mix-audio ((dst (* uint8)) (src (* uint8)) (len uint32) (volume int)) "SDL_MixAudio")
(define-sdl-func void sdl-mix-audio-format ((dst (* uint8)) (src (* uint8)) (format sdl-audio-format-t) (len uint32) (volume int)) "SDL_MixAudioFormat")



(define-sdl-func void sdl-lock-audio () "SDL_LockAudio")
(define-sdl-func void sdl-lock-audio-device ((dev sdl-audio-device-id-t)) "SDL_LockAudioDevice")
(define-sdl-func void sdl-unlock-audio () "SDL_UnlockAudio")
(define-sdl-func void sdl-unlock-audio-device ((dev sdl-audio-device-id-t)) "SDL_UnlockAudioDevice")
(define-sdl-func void sdl-close-audio () "SDL_CloseAudio")
(define-sdl-func void sdl-close-audio-device ((dev sdl-audio-device-id-t)) "SDL_CloseAudioDevice")

(define-sdl-func void sdl-pause-audio-device ((dev sdl-audio-device-id-t) (pause_on int)) "SDL_PauseAudioDevice")
(define-sdl-func (* sdl-audio-spec-t) sdl-load-wav-rw ((src (* sdl-rw-ops-t)) (freesrc int) (spec (* sdl-audio-spec-t)) (audio_buf (* uint8)) (audio_len (* uint32))) "SDL_LoadWAV_RW")
(define-sdl-func void sdl-free-wav ((audio_buf (* uint8))) "SDL_FreeWAV")
(define-sdl-func int sdl-build-audio-cvt ((cvt (* sdl-audio-cvt-t)) (src_format sdl-audio-format-t) (src_channels uint8) (src_rate int) (dst_format sdl-audio-format-t) (dst_channels uint8) (dst_rate int)) "SDL_BuildAudioCVT")
(define-sdl-func int sdl-convert-audio ((cvt (* sdl-audio-cvt-t))) "SDL_ConvertAudio")
(define-sdl-func void sdl-mix-audio ((dst (* uint8)) (src (* uint8)) (len uint32) (volume int)) "SDL_MixAudio")
(define-sdl-func void sdl-mix-audio-format ((dst (* uint8)) (src (* uint8)) (format sdl-audio-format-t) (len uint32) (volume int)) "SDL_MixAudioFormat")
(define-sdl-func int sdl-queue-audio ((dev sdl-audio-device-id-t) (data void*) (len uint32)) "SDL_QueueAudio")
(define-sdl-func uint32 sdl-get-queued-audio-size ((dev sdl-audio-device-id-t)) "SDL_GetQueuedAudioSize")
(define-sdl-func void sdl-clear-queued-audio ((dev sdl-audio-device-id-t)) "SDL_ClearQueuedAudio")
(define-sdl-func void sdl-lock-audio () "SDL_LockAudio")
(define-sdl-func void sdl-lock-audio-device ((dev sdl-audio-device-id-t)) "SDL_LockAudioDevice")
(define-sdl-func void sdl-unlock-audio () "SDL_UnlockAudio")
(define-sdl-func void sdl-unlock-audio-device ((dev sdl-audio-device-id-t)) "SDL_UnlockAudioDevice")
(define-sdl-func void sdl-close-audio () "SDL_CloseAudio")
(define-sdl-func void sdl-close-audio-device ((dev sdl-audio-device-id-t)) "SDL_CloseAudioDevice")

 (define-ftype sdl-audio-device-id-t uint32)
 (define-enumeration* sdl-audio-status
   (stopped playing paused))
 (define-ftype sdl-audio-format-t uint16)
 (define-ftype sdl-audio-callback-t void*)
 (define-ftype sdl-audio-spec-t

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-audio-device-id-t uint32)
 (define-enumeration* sdl-audio-status
   (stopped playing paused))
 (define-ftype sdl-audio-format-t uint16)
 (define-ftype sdl-audio-callback-t void*)
 (define-ftype sdl-audio-spec-t

(define-sdl-func sdl-bool-t sdl-has3-d-now () "SDL_Has3DNow")
(define-sdl-func sdl-bool-t sdl-has-sse () "SDL_HasSSE")
(define-sdl-func sdl-bool-t sdl-has-ss-e2 () "SDL_HasSSE2")
(define-sdl-func sdl-bool-t sdl-has-ss-e3 () "SDL_HasSSE3")
(define-sdl-func sdl-bool-t sdl-has-ss-e41 () "SDL_HasSSE41")
(define-sdl-func sdl-bool-t sdl-has-ss-e42 () "SDL_HasSSE42")
(define-sdl-func sdl-bool-t sdl-has-avx () "SDL_HasAVX")

(define-sdl-func int sdl-get-system-ram () "SDL_GetSystemRAM")

(define-sdl-func sdl-bool-t sdl-has3-d-now () "SDL_Has3DNow")
(define-sdl-func sdl-bool-t sdl-has-sse () "SDL_HasSSE")
(define-sdl-func sdl-bool-t sdl-has-ss-e2 () "SDL_HasSSE2")
(define-sdl-func sdl-bool-t sdl-has-ss-e3 () "SDL_HasSSE3")
(define-sdl-func sdl-bool-t sdl-has-ss-e41 () "SDL_HasSSE41")
(define-sdl-func sdl-bool-t sdl-has-ss-e42 () "SDL_HasSSE42")
(define-sdl-func sdl-bool-t sdl-has-avx () "SDL_HasAVX")
(define-sdl-func sdl-bool-t sdl-has-av-x2 () "SDL_HasAVX2")
(define-sdl-func int sdl-get-system-ram () "SDL_GetSystemRAM")

 (define-enumeration* sdl-errorcode
   (enomem efread efwrite efseek unsupported lasterror))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-enumeration* sdl-errorcode
   (enomem efread efwrite efseek unsupported lasterror))

(define-flags sdl-event-type
    (firstevent       0 ) ;     /**< unused (do not remove) */

    ;/* application events */
    (quit             #x100) ; /**< user-requested quit */

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-flags sdl-event-type
    (firstevent       0 ) ;     /**< unused (do not remove) */

    ;/* application events */
    (quit             #x100) ; /**< user-requested quit */

(define-sdl-func int sdl-game-controller-add-mappings-from-rw ((rw (* sdl-rw-ops-t)) (freerw int)) "SDL_GameControllerAddMappingsFromRW")
(define-sdl-func int sdl-game-controller-add-mapping ((mappingString string)) "SDL_GameControllerAddMapping")

;(define-sdl-func string sdl-game-controller-mapping-for-guid ((guid sdl-joystick-guid-t)) "SDL_GameControllerMappingForGUID")
(define-sdl-func string sdl-game-controller-mapping ((gamecontroller (* sdl-game-controller-t))) "SDL_GameControllerMapping")
(define-sdl-func sdl-bool-t sdl-is-game-controller ((joystick_index int)) "SDL_IsGameController")
(define-sdl-func string sdl-game-controller-name-for-index ((joystick_index int)) "SDL_GameControllerNameForIndex")
(define-sdl-func (* sdl-game-controller-t) sdl-game-controller-open ((joystick_index int)) "SDL_GameControllerOpen")

(define-sdl-func string sdl-game-controller-name ((gamecontroller (* sdl-game-controller-t))) "SDL_GameControllerName")
(define-sdl-func sdl-bool-t sdl-game-controller-get-attached ((gamecontroller (* sdl-game-controller-t))) "SDL_GameControllerGetAttached")
(define-sdl-func (* sdl-joystick-t) sdl-game-controller-get-joystick ((gamecontroller (* sdl-game-controller-t))) "SDL_GameControllerGetJoystick")
(define-sdl-func int sdl-game-controller-event-state ((state int)) "SDL_GameControllerEventState")
(define-sdl-func void sdl-game-controller-update () "SDL_GameControllerUpdate")
(define-sdl-func sdl-game-controller-axis-t sdl-game-controller-get-axis-from-string ((pchString string)) "SDL_GameControllerGetAxisFromString")
(define-sdl-func string sdl-game-controller-get-string-for-axis ((axis sdl-game-controller-axis-t)) "SDL_GameControllerGetStringForAxis")

(define-sdl-func int sdl-game-controller-add-mappings-from-rw ((rw (* sdl-rw-ops-t)) (freerw int)) "SDL_GameControllerAddMappingsFromRW")
(define-sdl-func int sdl-game-controller-add-mapping ((mappingString string)) "SDL_GameControllerAddMapping")
;;blacklisted probably because it uses a struct as value.
(define sdl-game-controller-mapping-for-guid #f)
(define-sdl-func string sdl-game-controller-mapping ((gamecontroller (* sdl-game-controller-t))) "SDL_GameControllerMapping")
(define-sdl-func sdl-bool-t sdl-is-game-controller ((joystick_index int)) "SDL_IsGameController")
(define-sdl-func string sdl-game-controller-name-for-index ((joystick_index int)) "SDL_GameControllerNameForIndex")
(define-sdl-func (* sdl-game-controller-t) sdl-game-controller-open ((joystick_index int)) "SDL_GameControllerOpen")
(define-sdl-func (* sdl-game-controller-t) sdl-game-controller-from-instance-id ((joyid sdl-joystick-id-t)) "SDL_GameControllerFromInstanceID")
(define-sdl-func string sdl-game-controller-name ((gamecontroller (* sdl-game-controller-t))) "SDL_GameControllerName")
(define-sdl-func sdl-bool-t sdl-game-controller-get-attached ((gamecontroller (* sdl-game-controller-t))) "SDL_GameControllerGetAttached")
(define-sdl-func (* sdl-joystick-t) sdl-game-controller-get-joystick ((gamecontroller (* sdl-game-controller-t))) "SDL_GameControllerGetJoystick")
(define-sdl-func int sdl-game-controller-event-state ((state int)) "SDL_GameControllerEventState")
(define-sdl-func void sdl-game-controller-update () "SDL_GameControllerUpdate")
(define-sdl-func sdl-game-controller-axis-t sdl-game-controller-get-axis-from-string ((pchString string)) "SDL_GameControllerGetAxisFromString")
(define-sdl-func string sdl-game-controller-get-string-for-axis ((axis sdl-game-controller-axis-t)) "SDL_GameControllerGetStringForAxis")

 (define-ftype sdl-gesture-id-t integer-64)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-gesture-id-t integer-64)

(define sdl-guardian (make-guardian))

 (define (sdl-guard-pointer obj) 
   (sdl-free-garbage) 
   (sdl-guardian obj) 
   obj)
 
 (define sdl-free-garbage-func (lambda () (if #f #f)))
 (define (sdl-free-garbage-set-func f) (set! sdl-free-garbage-func f))
 (define (sdl-free-garbage) (sdl-free-garbage-func))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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 sdl-guardian (make-guardian))

 (define (sdl-guard-pointer obj) 
   (sdl-free-garbage) 
   (sdl-guardian obj) 
   obj)
 
 (define sdl-free-garbage-func (lambda () (if #f #f)))
 (define (sdl-free-garbage-set-func f) (set! sdl-free-garbage-func f))
 (define (sdl-free-garbage) (sdl-free-garbage-func))

(define-enumeration* sdl-hint-priority
  (default
    normal
    override))

(define-ftype sdl-hint-callback-t void*)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-enumeration* sdl-hint-priority
  (default
    normal
    override))

(define-ftype sdl-hint-callback-t void*)

(define-sdl-func int sdl-num-joysticks () "SDL_NumJoysticks")
(define-sdl-func string sdl-joystick-name-for-index ((device_index int)) "SDL_JoystickNameForIndex")
(define-sdl-func (* sdl-joystick-t) sdl-joystick-open ((device_index int)) "SDL_JoystickOpen")

(define-sdl-func string sdl-joystick-name ((joystick (* sdl-joystick-t))) "SDL_JoystickName")
;;blacklisted probably because it uses a struct as value.
(define sdl-joystick-get-device-guid #f)
;;blacklisted probably because it uses a struct as value.
(define sdl-joystick-get-guid #f)
;;blacklisted probably because it uses a struct as value.
(define sdl-joystick-get-guid-string #f)
................................................................................
(define-sdl-func void sdl-joystick-update () "SDL_JoystickUpdate")
(define-sdl-func int sdl-joystick-event-state ((state int)) "SDL_JoystickEventState")
(define-sdl-func sint16 sdl-joystick-get-axis ((joystick (* sdl-joystick-t)) (axis int)) "SDL_JoystickGetAxis")
(define-sdl-func uint8 sdl-joystick-get-hat ((joystick (* sdl-joystick-t)) (hat int)) "SDL_JoystickGetHat")
(define-sdl-func int sdl-joystick-get-ball ((joystick (* sdl-joystick-t)) (ball int) (dx (* int)) (dy (* int))) "SDL_JoystickGetBall")
(define-sdl-func uint8 sdl-joystick-get-button ((joystick (* sdl-joystick-t)) (button int)) "SDL_JoystickGetButton")
(define-sdl-func void sdl-joystick-close ((joystick (* sdl-joystick-t))) "SDL_JoystickClose")

(define-sdl-func int sdl-num-joysticks () "SDL_NumJoysticks")
(define-sdl-func string sdl-joystick-name-for-index ((device_index int)) "SDL_JoystickNameForIndex")
(define-sdl-func (* sdl-joystick-t) sdl-joystick-open ((device_index int)) "SDL_JoystickOpen")
(define-sdl-func (* sdl-joystick-t) sdl-joystick-from-instance-id ((joyid sdl-joystick-id-t)) "SDL_JoystickFromInstanceID")
(define-sdl-func string sdl-joystick-name ((joystick (* sdl-joystick-t))) "SDL_JoystickName")
;;blacklisted probably because it uses a struct as value.
(define sdl-joystick-get-device-guid #f)
;;blacklisted probably because it uses a struct as value.
(define sdl-joystick-get-guid #f)
;;blacklisted probably because it uses a struct as value.
(define sdl-joystick-get-guid-string #f)
................................................................................
(define-sdl-func void sdl-joystick-update () "SDL_JoystickUpdate")
(define-sdl-func int sdl-joystick-event-state ((state int)) "SDL_JoystickEventState")
(define-sdl-func sint16 sdl-joystick-get-axis ((joystick (* sdl-joystick-t)) (axis int)) "SDL_JoystickGetAxis")
(define-sdl-func uint8 sdl-joystick-get-hat ((joystick (* sdl-joystick-t)) (hat int)) "SDL_JoystickGetHat")
(define-sdl-func int sdl-joystick-get-ball ((joystick (* sdl-joystick-t)) (ball int) (dx (* int)) (dy (* int))) "SDL_JoystickGetBall")
(define-sdl-func uint8 sdl-joystick-get-button ((joystick (* sdl-joystick-t)) (button int)) "SDL_JoystickGetButton")
(define-sdl-func void sdl-joystick-close ((joystick (* sdl-joystick-t))) "SDL_JoystickClose")
(define-sdl-func sdl-joystick-power-level-t sdl-joystick-current-power-level ((joystick (* sdl-joystick-t))) "SDL_JoystickCurrentPowerLevel")

 (define-ftype sdl-joystick-t (struct))
 (define-ftype sdl-joystick-guid-t (struct (data (array 16 uint8))))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-joystick-t (struct))
 (define-ftype sdl-joystick-guid-t (struct (data (array 16 uint8))))

(define sdl-joystick-power-level-unknown -1)
(define-enumeration* sdl-joystick-power-level
  (empty  low medium full wired max))

 (define-ftype sdl-keysym-t
   (struct
       (scancode sdl-scancode-t) 
       (sym sdl-keycode-t) 
       (mod unsigned-16) 
       (unused unsigned-32)))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-keysym-t
   (struct
       (scancode sdl-scancode-t) 
       (sym sdl-keycode-t) 
       (mod unsigned-16) 
       (unused unsigned-32)))

 (define-flags sdl-message-box (error  #x10) (warning #x20) (information #x40))
                                     
 (define-flags sdl-message-box-button
   (returnkey-default 1) (escapekey-default 2))
                                       
 (define-enumeration* sdl-message-box-color-type-t

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-flags sdl-message-box (error  #x10) (warning #x20) (information #x40))
                                     
 (define-flags sdl-message-box-button
   (returnkey-default 1) (escapekey-default 2))
                                       
 (define-enumeration* sdl-message-box-color-type-t

(define-sdl-func (* sdl-window-t) sdl-get-mouse-focus () "SDL_GetMouseFocus")
(define-sdl-func uint32 sdl-get-mouse-state ((x (* int)) (y (* int))) "SDL_GetMouseState")

(define-sdl-func uint32 sdl-get-relative-mouse-state ((x (* int)) (y (* int))) "SDL_GetRelativeMouseState")
(define-sdl-func void sdl-warp-mouse-in-window ((window (* sdl-window-t)) (x int) (y int)) "SDL_WarpMouseInWindow")

(define-sdl-func int sdl-set-relative-mouse-mode ((enabled sdl-bool-t)) "SDL_SetRelativeMouseMode")

(define-sdl-func sdl-bool-t sdl-get-relative-mouse-mode () "SDL_GetRelativeMouseMode")
(define-sdl-func (* sdl-cursor-t) sdl-create-cursor ((data (* uint8)) (mask (* uint8)) (w int) (h int) (hot_x int) (hot_y int)) "SDL_CreateCursor")
(define-sdl-func (* sdl-cursor-t) sdl-create-color-cursor ((surface (* sdl-surface-t)) (hot_x int) (hot_y int)) "SDL_CreateColorCursor")
(define-sdl-func (* sdl-cursor-t) sdl-create-system-cursor ((id sdl-system-cursor-t)) "SDL_CreateSystemCursor")
(define-sdl-func void sdl-set-cursor ((cursor (* sdl-cursor-t))) "SDL_SetCursor")
(define-sdl-func (* sdl-cursor-t) sdl-get-cursor () "SDL_GetCursor")
(define-sdl-func (* sdl-cursor-t) sdl-get-default-cursor () "SDL_GetDefaultCursor")
(define-sdl-func void sdl-free-cursor ((cursor (* sdl-cursor-t))) "SDL_FreeCursor")
(define-sdl-func int sdl-show-cursor ((toggle int)) "SDL_ShowCursor")

(define-sdl-func (* sdl-window-t) sdl-get-mouse-focus () "SDL_GetMouseFocus")
(define-sdl-func uint32 sdl-get-mouse-state ((x (* int)) (y (* int))) "SDL_GetMouseState")
(define-sdl-func uint32 sdl-get-global-mouse-state ((x (* int)) (y (* int))) "SDL_GetGlobalMouseState")
(define-sdl-func uint32 sdl-get-relative-mouse-state ((x (* int)) (y (* int))) "SDL_GetRelativeMouseState")
(define-sdl-func void sdl-warp-mouse-in-window ((window (* sdl-window-t)) (x int) (y int)) "SDL_WarpMouseInWindow")
(define-sdl-func int sdl-warp-mouse-global ((x int) (y int)) "SDL_WarpMouseGlobal")
(define-sdl-func int sdl-set-relative-mouse-mode ((enabled sdl-bool-t)) "SDL_SetRelativeMouseMode")
(define-sdl-func int sdl-capture-mouse ((enabled sdl-bool-t)) "SDL_CaptureMouse")
(define-sdl-func sdl-bool-t sdl-get-relative-mouse-mode () "SDL_GetRelativeMouseMode")
(define-sdl-func (* sdl-cursor-t) sdl-create-cursor ((data (* uint8)) (mask (* uint8)) (w int) (h int) (hot_x int) (hot_y int)) "SDL_CreateCursor")
(define-sdl-func (* sdl-cursor-t) sdl-create-color-cursor ((surface (* sdl-surface-t)) (hot_x int) (hot_y int)) "SDL_CreateColorCursor")
(define-sdl-func (* sdl-cursor-t) sdl-create-system-cursor ((id sdl-system-cursor-t)) "SDL_CreateSystemCursor")
(define-sdl-func void sdl-set-cursor ((cursor (* sdl-cursor-t))) "SDL_SetCursor")
(define-sdl-func (* sdl-cursor-t) sdl-get-cursor () "SDL_GetCursor")
(define-sdl-func (* sdl-cursor-t) sdl-get-default-cursor () "SDL_GetDefaultCursor")
(define-sdl-func void sdl-free-cursor ((cursor (* sdl-cursor-t))) "SDL_FreeCursor")
(define-sdl-func int sdl-show-cursor ((toggle int)) "SDL_ShowCursor")

 (define-enumeration* sdl-system-cursor
   (arrow     ; arrow */
    i-beam     ; i-beam */
    wait      ; wait */
    crosshair ; crosshair */
    waitarrow ; small wait cursor (or wait if not available) */

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-enumeration* sdl-system-cursor
   (arrow     ; arrow */
    i-beam     ; i-beam */
    wait      ; wait */
    crosshair ; crosshair */
    waitarrow ; small wait cursor (or wait if not available) */

 (define-ftype sdl-mutex-t (struct))
 (define-ftype sdl-sem-t (struct))
 (define-ftype sdl-cond-t (struct))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-mutex-t (struct))
 (define-ftype sdl-sem-t (struct))
 (define-ftype sdl-cond-t (struct))

(import (scheme)
	(json))

(define sdl-json-text (read-file "sdl2.json"))
(define sdl-json (string->json sdl-json-text))

(with-output-to-file "sdl2.sexp" (lambda () (pretty-print sdl-json)) 'truncate)

(import (only (thunder-utils) string-replace string-split) 
	(only (srfi s13 strings) string-drop string-downcase string-prefix? string-suffix? string-delete)
	(only (srfi s1 lists) fold)
	(srfi s14 char-sets))

;; (define (anti-camel x)
;;   (let* ([x (string-replace x #\_ #\-)]
;; 	 [len (string-length x)]
;; 	 [s (list->string
;; 	     (reverse
;; 	      (fold (lambda (i acc) 
;; 		      (let ([a (string-ref x i)] 
;; 			    [b (if (< (+ 1 i) len) (string-ref x (+ 1 i)) #f)]
;; 			    [c (if (> i 0) (string-ref x (- i 1)) #f)])
;; 			(if (and (char-upper-case? a) 
;; 				 b (not (char-upper-case? b)) c (not (char-upper-case? c)))
;; 			    (cons (char-downcase a) 
;; 				  (if (and c (char=? c #\-)) 
;; 				      acc 
;; 				      (cons #\- acc)))
;; 			    (cons (char-downcase a) acc)))) '() (iota len))))])
    
;;     s))

(define (anti-camel x)
  (let* ([x (string-replace x #\_ #\-)]
	 [len (string-length x)]
	 [f (lambda (s len)
	      (list->string
	       (reverse
		(fold (lambda (i acc) 
................................................................................
			      [prev (if (> i 0) (string-ref s (- i 1)) #f)])
			  (if (and (char-upper-case? a)  next prev
				   (not 
				    (or (char=? a #\-) (char=? prev #\-) (char=? next #\-)
					(and (char-upper-case? next) (char-upper-case? prev)))))
			      (cons (char-downcase a) (cons #\- acc))
			      (cons (char-downcase a) acc)))) '() (iota len)))))])



    (cond
     [(string-prefix? "SDL-GL-" x)
      (string-append "sdl-gl-" (f (string-drop x 7) (- len 7)))]
     [(string-prefix? "SDL-GL" x)
      (string-append "sdl-gl-" (f (string-drop x 6) (- len 6)))]
     [(equal? "SDL-RWops" x) "sdl-rw-ops"] ;HACK
     [else (f x len)])))

(define (add-t x)
  (let ([xd (string-downcase x)])
    (if (and (string-prefix? "sdl-" xd) 
	     (not  (or (string-suffix? "*" x) (string-suffix? "-t" x))))
	(string-append x "-t")
................................................................................
			   [:long 'long]
			   [:double 'double]
			   [:long-double 'long-double]
			   [:float 'float]
			   [:pointer (let ([pt (decode-type type)])
				       (case pt
					 (char 'string)

					 (void 'void*)
					 (else
					  (if (and (pair? pt ) (eq? (car pt) '*))
					      pt ;; DOUBLE STAR SEEMS NOT SUPPORTED ON CHEZ
					      `(* ,pt))
					  #;(string->symbol 
					   (add-*
................................................................................
			   [else (if (symbol? tag*)
				     (string->symbol 
				      (add-t
				       (anti-camel 
					(symbol->string tag*))))
				     tag*)])))
      #f))
(define (decode-param p)
  (let-json-object p (tag name type)
		   (if (equal? name "") 
		       (decode-type type)
		       (list name (decode-type type)))))

(define blacklist '(sdl-joystick-instance-id 
		    sdl-joystick-get-device-guid
		    sdl-joystick-get-guid 
		    sdl-joystick-get-guid-string 
		    sdl-joystick-get-guid-from-string
................................................................................

(import (only (srfi s13 strings) string-contains))
(define (parse-json-function x m)
  (let-json-object x (tag name location return-type parameters) 
		   (if (and (or (string-contains location m) 
				(and (equal? "sdl" m) (string-contains location "SDL.h")))
			    (equal? tag "function")
			    (string-prefix? "SDL_" name))

		       (cond
			[(memq (string->symbol (anti-camel name)) blacklist)
			 (printf ";;blacklisted probably because it uses a struct as value.\n(define ~d #f)\n" (anti-camel name))]
			[else
			   (printf "(define-sdl-func ~d ~d ~d \"~d\")\n"
				   (decode-type return-type) 
				   (case name
				     ("SDL_log" "sdl-logn")
				     (else (anti-camel name)))
				   

				   (map (lambda (p) (decode-param p)) (vector->list parameters))

				   name)]))))

(define sdl2-modules-func
  '(assert atomic audio clipboard
    cpuinfo endian error events 
    filesystem hints joystick
    keyboard loadso log main messagebox
    mouse mutex pixels platform power
    rect render rwops surface system
    thread timer touch version video gamecontroller gesture sdl))






(for-each (lambda (m) 
	    (with-output-to-file (string-append m "-functions.ss")
	      (lambda () 
		(vector-for-each 
		 (lambda (x) 
		   (parse-json-function x m))
		 sdl-json))
	      'truncate)) (map symbol->string sdl2-modules-func))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

(import (scheme)
	(json))






(import (only (thunder-utils) string-replace string-split) 
	(only (srfi s13 strings) string-drop string-downcase string-prefix? string-suffix? string-delete)
	(only (srfi s1 lists) fold)
	(srfi s14 char-sets))




















(define (anti-camel x)
  (let* ([x (string-replace x #\_ #\-)]
	 [len (string-length x)]
	 [f (lambda (s len)
	      (list->string
	       (reverse
		(fold (lambda (i acc) 
................................................................................
			      [prev (if (> i 0) (string-ref s (- i 1)) #f)])
			  (if (and (char-upper-case? a)  next prev
				   (not 
				    (or (char=? a #\-) (char=? prev #\-) (char=? next #\-)
					(and (char-upper-case? next) (char-upper-case? prev)))))
			      (cons (char-downcase a) (cons #\- acc))
			      (cons (char-downcase a) acc)))) '() (iota len)))))])
    (define tbl '(("SDL-RWops" "sdl-rw-ops")
		  ("UDPpacket" "udp-packet") ("TCPsocket" "tcp-socket")
		  ("IPaddress" "ip-address") ("UDPsocket" "udp-socket")))
    (cond
     [(string-prefix? "SDL-GL-" x)
      (string-append "sdl-gl-" (f (string-drop x 7) (- len 7)))]
     [(string-prefix? "SDL-GL" x)
      (string-append "sdl-gl-" (f (string-drop x 6) (- len 6)))]
     [(assoc x tbl) => (lambda (y) (cadr y))]
     [else (f x len)])))

(define (add-t x)
  (let ([xd (string-downcase x)])
    (if (and (string-prefix? "sdl-" xd) 
	     (not  (or (string-suffix? "*" x) (string-suffix? "-t" x))))
	(string-append x "-t")
................................................................................
			   [:long 'long]
			   [:double 'double]
			   [:long-double 'long-double]
			   [:float 'float]
			   [:pointer (let ([pt (decode-type type)])
				       (case pt
					 (char 'string)
					 (string 'void*)
					 (void 'void*)
					 (else
					  (if (and (pair? pt ) (eq? (car pt) '*))
					      pt ;; DOUBLE STAR SEEMS NOT SUPPORTED ON CHEZ
					      `(* ,pt))
					  #;(string->symbol 
					   (add-*
................................................................................
			   [else (if (symbol? tag*)
				     (string->symbol 
				      (add-t
				       (anti-camel 
					(symbol->string tag*))))
				     tag*)])))
      #f))
(define (decode-param p n)
  (let-json-object p (tag name type)
		   (if (equal? name "") 
		       (list (string-append "arg-" (number->string n)) (decode-type type))
		       (list name (decode-type type)))))

(define blacklist '(sdl-joystick-instance-id 
		    sdl-joystick-get-device-guid
		    sdl-joystick-get-guid 
		    sdl-joystick-get-guid-string 
		    sdl-joystick-get-guid-from-string
................................................................................

(import (only (srfi s13 strings) string-contains))
(define (parse-json-function x m)
  (let-json-object x (tag name location return-type parameters) 
		   (if (and (or (string-contains location m) 
				(and (equal? "sdl" m) (string-contains location "SDL.h")))
			    (equal? tag "function")
			    (or (string-prefix? "SDL_" name)
				(string-prefix? "SDLNet_" name)))
		       (cond
			[(memq (string->symbol (anti-camel name)) blacklist)
			 (printf ";;blacklisted probably because it uses a struct as value.\n(define ~d #f)\n" (anti-camel name))]
			[else
			   (printf "(define-sdl-func ~d ~d ~d \"~d\")\n"
				   (decode-type return-type) 
				   (case name
				     ("SDL_log" "sdl-logn")
				     (else (anti-camel name)))
				   
				   (map (lambda (p n) (decode-param p n)) 
					(vector->list parameters) 
					(iota (vector-length parameters)))
				   name)]))))

(define sdl2-modules-func
  '(assert atomic audio clipboard
    cpuinfo endian error events 
    filesystem hints joystick
    keyboard loadso log main messagebox
    mouse mutex pixels platform power
    rect render rwops surface system
    thread timer touch version video gamecontroller gesture sdl))

(define sdl-json-text (read-file "sdl2.json"))
(define sdl-json (string->json sdl-json-text))

(with-output-to-file "sdl2.sexp" (lambda () (pretty-print sdl-json)) 'truncate)

(for-each (lambda (m) 
	    (with-output-to-file (string-append m "-functions.ss")
	      (lambda () 
		(vector-for-each 
		 (lambda (x) 
		   (parse-json-function x m))
		 sdl-json))
	      'truncate)) (map symbol->string sdl2-modules-func))

(define sdlnet-json-text (read-file "sdl2-net.json"))
(define sdlnet-json (string->json sdlnet-json-text))

(with-output-to-file "sdl2-net.sexp" (lambda () (pretty-print sdlnet-json)) 'truncate)

(for-each (lambda (m) 
	    (with-output-to-file (string-append m "-functions.ss")
	      (lambda () 
		(vector-for-each 
		 (lambda (x)
		   (parse-json-function x m))
		 sdlnet-json))
	      'truncate)) '("net"))

(begin
  (define sdl-alpha-opaque 255)
  (define sdl-alpha-transparent 0)

  (define-enumeration* sdl-pixeltype ( unknown index-1 index-4 index-8 packed-8 packed-16 
						packed-32 array-u8 array-u16 array-u32 array-f16 array-f32))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

(begin
  (define sdl-alpha-opaque 255)
  (define sdl-alpha-transparent 0)

  (define-enumeration* sdl-pixeltype ( unknown index-1 index-4 index-8 packed-8 packed-16 
						packed-32 array-u8 array-u16 array-u32 array-f16 array-f32))

(define-sdl-func sdl-bool-t sdl-rect-empty ((r (* sdl-rect-t))) "SDL_RectEmpty")
(define-sdl-func sdl-bool-t sdl-rect-equals ((a (* sdl-rect-t)) (b (* sdl-rect-t))) "SDL_RectEquals")
(define-sdl-func sdl-bool-t sdl-has-intersection ((A (* sdl-rect-t)) (B (* sdl-rect-t))) "SDL_HasIntersection")
(define-sdl-func sdl-bool-t sdl-intersect-rect ((A (* sdl-rect-t)) (B (* sdl-rect-t)) (result (* sdl-rect-t))) "SDL_IntersectRect")
(define-sdl-func void sdl-union-rect ((A (* sdl-rect-t)) (B (* sdl-rect-t)) (result (* sdl-rect-t))) "SDL_UnionRect")
(define-sdl-func sdl-bool-t sdl-enclose-points ((points (* sdl-point-t)) (count int) (clip (* sdl-rect-t)) (result (* sdl-rect-t))) "SDL_EnclosePoints")
(define-sdl-func sdl-bool-t sdl-intersect-rect-and-line ((rect (* sdl-rect-t)) (X1 (* int)) (Y1 (* int)) (X2 (* int)) (Y2 (* int))) "SDL_IntersectRectAndLine")

(define-sdl-func sdl-bool-t sdl-point-in-rect ((p (* sdl-point-t)) (r (* sdl-rect-t))) "SDL_PointInRect")
(define-sdl-func sdl-bool-t sdl-rect-empty ((r (* sdl-rect-t))) "SDL_RectEmpty")
(define-sdl-func sdl-bool-t sdl-rect-equals ((a (* sdl-rect-t)) (b (* sdl-rect-t))) "SDL_RectEquals")
(define-sdl-func sdl-bool-t sdl-has-intersection ((A (* sdl-rect-t)) (B (* sdl-rect-t))) "SDL_HasIntersection")
(define-sdl-func sdl-bool-t sdl-intersect-rect ((A (* sdl-rect-t)) (B (* sdl-rect-t)) (result (* sdl-rect-t))) "SDL_IntersectRect")
(define-sdl-func void sdl-union-rect ((A (* sdl-rect-t)) (B (* sdl-rect-t)) (result (* sdl-rect-t))) "SDL_UnionRect")
(define-sdl-func sdl-bool-t sdl-enclose-points ((points (* sdl-point-t)) (count int) (clip (* sdl-rect-t)) (result (* sdl-rect-t))) "SDL_EnclosePoints")
(define-sdl-func sdl-bool-t sdl-intersect-rect-and-line ((rect (* sdl-rect-t)) (X1 (* int)) (Y1 (* int)) (X2 (* int)) (Y2 (* int))) "SDL_IntersectRectAndLine")

(define-ftype sdl-point-t (struct (x int) (y int)))
(define-ftype sdl-rect-t (struct (x int) (y int) (w int) (h int)))
 

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-point-t (struct (x int) (y int)))
(define-ftype sdl-rect-t (struct (x int) (y int) (w int) (h int)))
 

(define-sdl-func (* sdl-texture-t) sdl-get-render-target ((renderer (* sdl-renderer-t))) "SDL_GetRenderTarget")
(define-sdl-func int sdl-render-set-logical-size ((renderer (* sdl-renderer-t)) (w int) (h int)) "SDL_RenderSetLogicalSize")
(define-sdl-func void sdl-render-get-logical-size ((renderer (* sdl-renderer-t)) (w (* int)) (h (* int))) "SDL_RenderGetLogicalSize")
(define-sdl-func int sdl-render-set-viewport ((renderer (* sdl-renderer-t)) (rect (* sdl-rect-t))) "SDL_RenderSetViewport")
(define-sdl-func void sdl-render-get-viewport ((renderer (* sdl-renderer-t)) (rect (* sdl-rect-t))) "SDL_RenderGetViewport")
(define-sdl-func int sdl-render-set-clip-rect ((renderer (* sdl-renderer-t)) (rect (* sdl-rect-t))) "SDL_RenderSetClipRect")
(define-sdl-func void sdl-render-get-clip-rect ((renderer (* sdl-renderer-t)) (rect (* sdl-rect-t))) "SDL_RenderGetClipRect")

(define-sdl-func int sdl-render-set-scale ((renderer (* sdl-renderer-t)) (scaleX float) (scaleY float)) "SDL_RenderSetScale")
(define-sdl-func void sdl-render-get-scale ((renderer (* sdl-renderer-t)) (scaleX (* float)) (scaleY (* float))) "SDL_RenderGetScale")
(define-sdl-func int sdl-set-render-draw-color ((renderer (* sdl-renderer-t)) (r uint8) (g uint8) (b uint8) (a uint8)) "SDL_SetRenderDrawColor")
(define-sdl-func int sdl-get-render-draw-color ((renderer (* sdl-renderer-t)) (r (* uint8)) (g (* uint8)) (b (* uint8)) (a (* uint8))) "SDL_GetRenderDrawColor")
(define-sdl-func int sdl-set-render-draw-blend-mode ((renderer (* sdl-renderer-t)) (blendMode sdl-blend-mode-t)) "SDL_SetRenderDrawBlendMode")
(define-sdl-func int sdl-get-render-draw-blend-mode ((renderer (* sdl-renderer-t)) (blendMode (* sdl-blend-mode-t))) "SDL_GetRenderDrawBlendMode")
(define-sdl-func int sdl-render-clear ((renderer (* sdl-renderer-t))) "SDL_RenderClear")

(define-sdl-func (* sdl-texture-t) sdl-get-render-target ((renderer (* sdl-renderer-t))) "SDL_GetRenderTarget")
(define-sdl-func int sdl-render-set-logical-size ((renderer (* sdl-renderer-t)) (w int) (h int)) "SDL_RenderSetLogicalSize")
(define-sdl-func void sdl-render-get-logical-size ((renderer (* sdl-renderer-t)) (w (* int)) (h (* int))) "SDL_RenderGetLogicalSize")
(define-sdl-func int sdl-render-set-viewport ((renderer (* sdl-renderer-t)) (rect (* sdl-rect-t))) "SDL_RenderSetViewport")
(define-sdl-func void sdl-render-get-viewport ((renderer (* sdl-renderer-t)) (rect (* sdl-rect-t))) "SDL_RenderGetViewport")
(define-sdl-func int sdl-render-set-clip-rect ((renderer (* sdl-renderer-t)) (rect (* sdl-rect-t))) "SDL_RenderSetClipRect")
(define-sdl-func void sdl-render-get-clip-rect ((renderer (* sdl-renderer-t)) (rect (* sdl-rect-t))) "SDL_RenderGetClipRect")
(define-sdl-func sdl-bool-t sdl-render-is-clip-enabled ((renderer (* sdl-renderer-t))) "SDL_RenderIsClipEnabled")
(define-sdl-func int sdl-render-set-scale ((renderer (* sdl-renderer-t)) (scaleX float) (scaleY float)) "SDL_RenderSetScale")
(define-sdl-func void sdl-render-get-scale ((renderer (* sdl-renderer-t)) (scaleX (* float)) (scaleY (* float))) "SDL_RenderGetScale")
(define-sdl-func int sdl-set-render-draw-color ((renderer (* sdl-renderer-t)) (r uint8) (g uint8) (b uint8) (a uint8)) "SDL_SetRenderDrawColor")
(define-sdl-func int sdl-get-render-draw-color ((renderer (* sdl-renderer-t)) (r (* uint8)) (g (* uint8)) (b (* uint8)) (a (* uint8))) "SDL_GetRenderDrawColor")
(define-sdl-func int sdl-set-render-draw-blend-mode ((renderer (* sdl-renderer-t)) (blendMode sdl-blend-mode-t)) "SDL_SetRenderDrawBlendMode")
(define-sdl-func int sdl-get-render-draw-blend-mode ((renderer (* sdl-renderer-t)) (blendMode (* sdl-blend-mode-t))) "SDL_GetRenderDrawBlendMode")
(define-sdl-func int sdl-render-clear ((renderer (* sdl-renderer-t))) "SDL_RenderClear")

(define-flags sdl-renderer-flags
  (software 1)
  (accelerated 2)
  (presentvsync 4)
  (targettexture 8))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-flags sdl-renderer-flags
  (software 1)
  (accelerated 2)
  (presentvsync 4)
  (targettexture 8))

 (define-ftype sdl-rw-ops-t (struct))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-rw-ops-t (struct))

(define-flags sdl-scancode
    (unknown   0)

    ;; /**
    ;;  *  \name usage page 0x07
    ;;  *
    ;;  *  these values are from usage page 0x07 (usb keyboard page).

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-flags sdl-scancode
    (unknown   0)

    ;; /**
    ;;  *  \name usage page 0x07
    ;;  *
    ;;  *  these values are from usage page 0x07 (usb keyboard page).

 (define-ftype sdl-blit-map-t (struct))
 (define-ftype sdl-surface-t
  (struct
   (flags uint32)
   (format (* sdl-pixel-format-t))
   (w int)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-blit-map-t (struct))
 (define-ftype sdl-surface-t
  (struct
   (flags uint32)
   (format (* sdl-pixel-format-t))
   (w int)

 (define-ftype sdl-thread-t (struct))
 (define-ftype sdl-thread-function-t void*)
 (define-ftype sdl-thread-id-t unsigned-long)
 (define-ftype sdl-tlsid-t unsigned-int)

 (define-enumeration* sdl-thread-priority
   ( low normal high ))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-thread-t (struct))
 (define-ftype sdl-thread-function-t void*)
 (define-ftype sdl-thread-id-t unsigned-long)
 (define-ftype sdl-tlsid-t unsigned-int)

 (define-enumeration* sdl-thread-priority
   ( low normal high ))

 (define-ftype sdl-timer-id-t int)
 ;(define-ftype sdl-timer-callback-t (function (uint32 void*) uint32))
 (define-ftype sdl-timer-callback-t void*)

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-timer-id-t int)
 ;(define-ftype sdl-timer-callback-t (function (uint32 void*) uint32))
 (define-ftype sdl-timer-callback-t void*)

(define-ftype sdl-finger-id-t integer-64)
(define-ftype sdl-touch-id-t integer-64)

(define sdl-touch-mouseid #xffffffff)

(define-ftype sdl-finger-t
  (struct 
   (id sdl-finger-id-t)
   (x float)
   (y float)
   (pressure float)))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-finger-id-t integer-64)
(define-ftype sdl-touch-id-t integer-64)

(define sdl-touch-mouseid #xffffffff)

(define-ftype sdl-finger-t
  (struct 
   (id sdl-finger-id-t)
   (x float)
   (y float)
   (pressure float)))

 (define-ftype sdl-version-t (struct (major uint8) (minor uint8) (patch uint8)))

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-version-t (struct (major uint8) (minor uint8) (patch uint8)))

(define-sdl-func string sdl-get-video-driver ((index int)) "SDL_GetVideoDriver")
(define-sdl-func int sdl-video-init ((driver_name string)) "SDL_VideoInit")
(define-sdl-func void sdl-video-quit () "SDL_VideoQuit")
(define-sdl-func string sdl-get-current-video-driver () "SDL_GetCurrentVideoDriver")
(define-sdl-func int sdl-get-num-video-displays () "SDL_GetNumVideoDisplays")
(define-sdl-func string sdl-get-display-name ((displayIndex int)) "SDL_GetDisplayName")
(define-sdl-func int sdl-get-display-bounds ((displayIndex int) (rect (* sdl-rect-t))) "SDL_GetDisplayBounds")

(define-sdl-func int sdl-get-num-display-modes ((displayIndex int)) "SDL_GetNumDisplayModes")
(define-sdl-func int sdl-get-display-mode ((displayIndex int) (modeIndex int) (mode (* sdl-display-mode-t))) "SDL_GetDisplayMode")
(define-sdl-func int sdl-get-desktop-display-mode ((displayIndex int) (mode (* sdl-display-mode-t))) "SDL_GetDesktopDisplayMode")
(define-sdl-func int sdl-get-current-display-mode ((displayIndex int) (mode (* sdl-display-mode-t))) "SDL_GetCurrentDisplayMode")
(define-sdl-func (* sdl-display-mode-t) sdl-get-closest-display-mode ((displayIndex int) (mode (* sdl-display-mode-t)) (closest (* sdl-display-mode-t))) "SDL_GetClosestDisplayMode")
(define-sdl-func int sdl-get-window-display-index ((window (* sdl-window-t))) "SDL_GetWindowDisplayIndex")
(define-sdl-func int sdl-set-window-display-mode ((window (* sdl-window-t)) (mode (* sdl-display-mode-t))) "SDL_SetWindowDisplayMode")
................................................................................
(define-sdl-func void sdl-restore-window ((window (* sdl-window-t))) "SDL_RestoreWindow")
(define-sdl-func int sdl-set-window-fullscreen ((window (* sdl-window-t)) (flags uint32)) "SDL_SetWindowFullscreen")
(define-sdl-func (* sdl-surface-t) sdl-get-window-surface ((window (* sdl-window-t))) "SDL_GetWindowSurface")
(define-sdl-func int sdl-update-window-surface ((window (* sdl-window-t))) "SDL_UpdateWindowSurface")
(define-sdl-func int sdl-update-window-surface-rects ((window (* sdl-window-t)) (rects (* sdl-rect-t)) (numrects int)) "SDL_UpdateWindowSurfaceRects")
(define-sdl-func void sdl-set-window-grab ((window (* sdl-window-t)) (grabbed sdl-bool-t)) "SDL_SetWindowGrab")
(define-sdl-func sdl-bool-t sdl-get-window-grab ((window (* sdl-window-t))) "SDL_GetWindowGrab")

(define-sdl-func int sdl-set-window-brightness ((window (* sdl-window-t)) (brightness float)) "SDL_SetWindowBrightness")
(define-sdl-func float sdl-get-window-brightness ((window (* sdl-window-t))) "SDL_GetWindowBrightness")
(define-sdl-func int sdl-set-window-gamma-ramp ((window (* sdl-window-t)) (red (* uint16)) (green (* uint16)) (blue (* uint16))) "SDL_SetWindowGammaRamp")
(define-sdl-func int sdl-get-window-gamma-ramp ((window (* sdl-window-t)) (red (* uint16)) (green (* uint16)) (blue (* uint16))) "SDL_GetWindowGammaRamp")

(define-sdl-func void sdl-destroy-window ((window (* sdl-window-t))) "SDL_DestroyWindow")
(define-sdl-func sdl-bool-t sdl-is-screen-saver-enabled () "SDL_IsScreenSaverEnabled")
(define-sdl-func void sdl-enable-screen-saver () "SDL_EnableScreenSaver")
(define-sdl-func void sdl-disable-screen-saver () "SDL_DisableScreenSaver")
(define-sdl-func int sdl-gl-load-library ((path string)) "SDL_GL_LoadLibrary")
(define-sdl-func void* sdl-gl-get-proc-address ((proc string)) "SDL_GL_GetProcAddress")
(define-sdl-func void sdl-gl-unload-library () "SDL_GL_UnloadLibrary")

(define-sdl-func string sdl-get-video-driver ((index int)) "SDL_GetVideoDriver")
(define-sdl-func int sdl-video-init ((driver_name string)) "SDL_VideoInit")
(define-sdl-func void sdl-video-quit () "SDL_VideoQuit")
(define-sdl-func string sdl-get-current-video-driver () "SDL_GetCurrentVideoDriver")
(define-sdl-func int sdl-get-num-video-displays () "SDL_GetNumVideoDisplays")
(define-sdl-func string sdl-get-display-name ((displayIndex int)) "SDL_GetDisplayName")
(define-sdl-func int sdl-get-display-bounds ((displayIndex int) (rect (* sdl-rect-t))) "SDL_GetDisplayBounds")
(define-sdl-func int sdl-get-display-dpi ((displayIndex int) (ddpi (* float)) (hdpi (* float)) (vdpi (* float))) "SDL_GetDisplayDPI")
(define-sdl-func int sdl-get-num-display-modes ((displayIndex int)) "SDL_GetNumDisplayModes")
(define-sdl-func int sdl-get-display-mode ((displayIndex int) (modeIndex int) (mode (* sdl-display-mode-t))) "SDL_GetDisplayMode")
(define-sdl-func int sdl-get-desktop-display-mode ((displayIndex int) (mode (* sdl-display-mode-t))) "SDL_GetDesktopDisplayMode")
(define-sdl-func int sdl-get-current-display-mode ((displayIndex int) (mode (* sdl-display-mode-t))) "SDL_GetCurrentDisplayMode")
(define-sdl-func (* sdl-display-mode-t) sdl-get-closest-display-mode ((displayIndex int) (mode (* sdl-display-mode-t)) (closest (* sdl-display-mode-t))) "SDL_GetClosestDisplayMode")
(define-sdl-func int sdl-get-window-display-index ((window (* sdl-window-t))) "SDL_GetWindowDisplayIndex")
(define-sdl-func int sdl-set-window-display-mode ((window (* sdl-window-t)) (mode (* sdl-display-mode-t))) "SDL_SetWindowDisplayMode")
................................................................................
(define-sdl-func void sdl-restore-window ((window (* sdl-window-t))) "SDL_RestoreWindow")
(define-sdl-func int sdl-set-window-fullscreen ((window (* sdl-window-t)) (flags uint32)) "SDL_SetWindowFullscreen")
(define-sdl-func (* sdl-surface-t) sdl-get-window-surface ((window (* sdl-window-t))) "SDL_GetWindowSurface")
(define-sdl-func int sdl-update-window-surface ((window (* sdl-window-t))) "SDL_UpdateWindowSurface")
(define-sdl-func int sdl-update-window-surface-rects ((window (* sdl-window-t)) (rects (* sdl-rect-t)) (numrects int)) "SDL_UpdateWindowSurfaceRects")
(define-sdl-func void sdl-set-window-grab ((window (* sdl-window-t)) (grabbed sdl-bool-t)) "SDL_SetWindowGrab")
(define-sdl-func sdl-bool-t sdl-get-window-grab ((window (* sdl-window-t))) "SDL_GetWindowGrab")
(define-sdl-func (* sdl-window-t) sdl-get-grabbed-window () "SDL_GetGrabbedWindow")
(define-sdl-func int sdl-set-window-brightness ((window (* sdl-window-t)) (brightness float)) "SDL_SetWindowBrightness")
(define-sdl-func float sdl-get-window-brightness ((window (* sdl-window-t))) "SDL_GetWindowBrightness")
(define-sdl-func int sdl-set-window-gamma-ramp ((window (* sdl-window-t)) (red (* uint16)) (green (* uint16)) (blue (* uint16))) "SDL_SetWindowGammaRamp")
(define-sdl-func int sdl-get-window-gamma-ramp ((window (* sdl-window-t)) (red (* uint16)) (green (* uint16)) (blue (* uint16))) "SDL_GetWindowGammaRamp")
(define-sdl-func int sdl-set-window-hit-test ((window (* sdl-window-t)) (callback sdl-hit-test-t) (callback_data void*)) "SDL_SetWindowHitTest")
(define-sdl-func void sdl-destroy-window ((window (* sdl-window-t))) "SDL_DestroyWindow")
(define-sdl-func sdl-bool-t sdl-is-screen-saver-enabled () "SDL_IsScreenSaverEnabled")
(define-sdl-func void sdl-enable-screen-saver () "SDL_EnableScreenSaver")
(define-sdl-func void sdl-disable-screen-saver () "SDL_DisableScreenSaver")
(define-sdl-func int sdl-gl-load-library ((path string)) "SDL_GL_LoadLibrary")
(define-sdl-func void* sdl-gl-get-proc-address ((proc string)) "SDL_GL_GetProcAddress")
(define-sdl-func void sdl-gl-unload-library () "SDL_GL_UnloadLibrary")

 (define-ftype sdl-display-mode-t ; /usr/include/SDL2/SDL_video.h:53:9
   (struct 
    (format uint32)
    (w int)
    (h int)
    (refresh-rate int)
................................................................................
	      share-with-current-context framebuffer-srgb-capable))

 (define-flags sdl-gl-profile (core 1) (compatibility 2) (es 4))

 (define-flags sdl-gl-context-flag (debug 1) (forward-compatible 2) (robust-access 4) (reset-isolation 8))

(define-ftype sdl-gl-context-t void*)
 

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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-ftype sdl-display-mode-t ; /usr/include/SDL2/SDL_video.h:53:9
   (struct 
    (format uint32)
    (w int)
    (h int)
    (refresh-rate int)
................................................................................
	      share-with-current-context framebuffer-srgb-capable))

 (define-flags sdl-gl-profile (core 1) (compatibility 2) (es 4))

 (define-flags sdl-gl-context-flag (debug 1) (forward-compatible 2) (robust-access 4) (reset-isolation 8))

(define-ftype sdl-gl-context-t void*)

(define-ftype sdl-hit-test-t void*) 
 ;; typedef SDL_HitTestResult (SDLCALL *SDL_HitTest)(SDL_Window *win,
 ;;                                                 const SDL_Point *area,
 ;;                                                 void *data);
 (define-enumeration* sdl-hit-test-result
   (normal draggable topleft top topright right bottomright bottom bottomleft left))

;; Licensed under an MIT-style license.  My license is in the file
;; named LICENSE from the original collection this file is distributed
;; with.  If this file is redistributed with some other collection, my
;; license must also be included.

#!r6rs
(library (srfi s26 cut)
  (export cut cute)


  (import (rnrs) (srfi private include))
  
  (include/resolve ("srfi" "s26") "cut.scm")  

)

;; Licensed under an MIT-style license.  My license is in the file
;; named LICENSE from the original collection this file is distributed
;; with.  If this file is redistributed with some other collection, my
;; license must also be included.

#!r6rs
(library (srfi s26 cut)
  (export cut cute <> <...>)
  (import (chezscheme) 
	  (srfi private auxiliary-keyword)
	  (srfi private include))

  (include/resolve ("srfi" "s26") "cut.scm")  
  (define-auxiliary-keywords <> <...>)
)

#!chezscheme
(library (usb)
 (export 
  usb-device-descriptor
  usb-device
  usb-device-handle

;;
;; Copyright 2016 Aldo Nicolas Bruno
;;
;; 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.

#!chezscheme
(library (usb)
 (export 
  usb-device-descriptor
  usb-device
  usb-device-handle