Meshes located at video module and new game loop procedure returning game elements

[gacela.git] / src / utils.scm

diff --git a/src/utils.scm b/src/utils.scm
index f2b339aa18ebbbfe365490ec59037f12dd3bb697..ed09712d9a990531d9e9daecdc81e1131596aed1 100644 (file)
--- a/src/utils.scm
+++ b/src/utils.scm
@@ -16,13 +16,18 @@
 
 
 (define-module (gacela utils)
-  #:use-module (ice-9 session)
   #:export (use-cache-with
-           procedure-header))
+           arguments-calling
+           arguments-apply
+           bound?
+           names-arguments
+           make-producer))
 
 
 ;;; Cache for procedures
+
 (define (use-cache-with proc)
+  "Cache for procedures"
   (let ((cache (make-weak-value-hash-table)))
     (lambda (. param)
       (let* ((key param)
@@ -34,9 +39,139 @@
               res))))))
 
 
-;;; Retrive header definition of a procedure
- (define (procedure-header proc)
-   (let* ((args (procedure-arguments proc))
-        (name (procedure-name proc))
-        (required (cdar args)))
-     (cons name required)))
+;;; Playing with procedures arguments
+
+(define undefined)
+(define (bound? var) (not (eq? var undefined)))
+
+(define (required-arguments args values)
+  "Return an alist with required arguments and their values"
+  (define (f vars values)
+    (cond ((null? vars) '())
+         ((null? values) (assoc-set! (f (cdr vars) '())
+                                     (car vars)
+                                     undefined))
+         (else (assoc-set! (f (cdr vars) (cdr values))
+                           (car vars)
+                           (car values)))))
+  (f (assoc-ref args 'required) values))
+
+(define (optional-arguments args values)
+  "Return an alist with optional arguments and their values"
+  (define (f vars values)
+    (cond ((null? vars) '())
+         ((null? values) (assoc-set! (f (cdr vars) '())
+                                     (car vars)
+                                     undefined))
+         (else (assoc-set! (f (cdr vars) (cdr values))
+                           (car vars)
+                           (car values)))))
+  (f (assoc-ref args 'optional)
+     (list-tail values
+               (min (length (assoc-ref args 'required))
+                    (length values)))))
+
+(define (keyword-arguments args values)
+  "Return an alist with keyword arguments and their values"
+  (define (f vars values)
+    (cond ((null? vars) '())
+         (else
+          (let ((val (member (car vars) values)))
+            (assoc-set! (f (cdr vars) values)
+                           (keyword->symbol (car vars))
+                           (if val (cadr val) undefined))))))
+  (f (map (lambda (x) (car x)) (assoc-ref args 'keyword)) values))
+
+(define (rest-arguments args values)
+  "Return an alist with rest arguments"
+  (let ((rest (assoc-ref args 'rest)))
+    (cond (rest (assoc-set! '()
+                           rest
+                           (list-tail values
+                                      (min (+ (length (assoc-ref args 'required))
+                                              (length (assoc-ref args 'optional)))
+                                           (length values)))))
+         (else '()))))
+
+(define (arguments-calling proc values)
+  "Return an alist with procedure arguments and their values"
+  (let ((args ((@ (ice-9 session) procedure-arguments) proc)))
+    (append (required-arguments args values)
+           (optional-arguments args values)
+           (keyword-arguments args values)
+           (rest-arguments args values))))
+
+(define (required-arguments-apply args values)
+  "Return a list with required arguments for use with apply"
+  (define (f vars values)
+    (cond ((null? vars) '())
+         (else 
+          (cons (assoc-ref values (car vars))
+                (f (cdr vars) values)))))
+  (f (assoc-ref args 'required) values))
+
+(define (optional-arguments-apply args values)
+  "Return a list with optional arguments for use with apply"
+  (define (f vars values)
+    (cond ((null? vars) '())
+         (else (let ((a (f (cdr vars) values))
+                     (val (assoc (car vars) values)))
+                 (cond ((and val (bound? (cdr val)))
+                        (cons (cdr val) a))
+                       (else a))))))
+  (f (assoc-ref args 'optional) values))
+
+(define (keyword-arguments-apply args values)
+  "Return a list with keyword arguments for use with apply"
+  (define (f vars values)
+    (cond ((null? vars) '())
+         (else (let ((a (f (cdr vars) values))
+                     (val (assoc (keyword->symbol (car vars)) values)))
+                 (cond ((and val (bound? (cdr val)))
+                        (cons (car vars) (cons (cdr val) a)))
+                       (else a))))))
+  (f (map (lambda (x) (car x)) (assoc-ref args 'keyword)) values))
+
+(define (rest-arguments-apply args values)
+  "Return a list with rest arguments for use with apply"
+  (let ((rest (assoc-ref args 'rest)))
+    (cond (rest (assoc-ref values rest))
+         (else '()))))
+  
+(define (arguments-apply proc values)
+  "Return a list for use with apply"
+  (let ((args ((@ (ice-9 session) procedure-arguments) proc)))
+    (append (required-arguments-apply args values)
+           (optional-arguments-apply args values)
+           (keyword-arguments-apply args values)
+           (rest-arguments-apply args values))))
+
+(define (names-arguments args)
+  (map (lambda (x) (if (list? x) (car x) x))
+       (filter (lambda (x) (not (keyword? x)))
+              (pair-to-list args))))
+
+
+;;; Continuations and coroutines
+
+(define (make-producer body)
+  (define resume #f)
+  (lambda (real-send)
+    (define send-to real-send)
+    (define (send value-to-send)
+      (set! send-to
+           (call/cc
+            (lambda (k)
+              (set! resume k)
+              (send-to value-to-send)))))
+    (if resume
+        (resume real-send)
+        (body send))))
+
+
+;;; Miscellaneous
+
+(define (pair-to-list pair)
+  (cond ((null? pair) '())
+       ((not (pair? pair)) (list pair))
+       (else (cons (car pair) (pair-to-list (cdr pair))))))