Controllers list for views

[gacela.git] / src / views.scm

diff --git a/src/views.scm b/src/views.scm
index b86af82b70854ccf1099d9dc7078c086f724f1d4..887c65cb9cbdeeecbee760f5e895493fa0b6629e 100644 (file)
--- a/src/views.scm
+++ b/src/views.scm
@@ -22,19 +22,86 @@
   #:use-module (ice-9 optargs))
 
 
   #:use-module (ice-9 optargs))
 
 

-(define default-view (make-hash-table))
+;;; Views

 
 

-(define* (draw-meshes #:optional (meshes (hash-map->list (lambda (k v) v) default-view)))
+(define view-type
+  (make-record-type "view" 
+                   '(id controllers meshes priority)
+                   (lambda (record port)
+                     (format port "#<view: ~a meshes>"
+                             (length (view-meshes record))))))
+
+(define (make-view controllers meshes priority) ((record-constructor view-type) (gensym) controllers meshes priority))
+(define view? (record-predicate view-type))
+(define view-id (record-accessor view-type 'id))
+(define view-meshes (record-accessor view-type 'meshes))
+(define view-meshes-set! (record-modifier view-type 'meshes))
+(define view-controllers (record-accessor view-type 'controllers))
+(define view-controllers-set! (record-modifier view-type 'controllers))
+(define view-priority (record-accessor view-type 'priority))
+
+(defmacro* view (#:key (priority 0) . elements)
+  `(let ((e (view-elements ,@elements)))
+     (make-view (car e) (cadr e) ,priority)))
+
+(define-macro (view-elements . elements)
+  (cond ((null? elements) `'(() ()))
+       (else
+        `(let ((l (view-elements ,@(cdr elements))))
+           ,(let ((e (car elements)))
+              `(cond ((mesh? ,e)
+                      (list (car l) (cons ,e (cadr l))))
+                     ((procedure? ,e)
+                      (list (cons ,(if (list? e) e `(lambda () (,e))) (car l))
+                            (cadr l)))
+                     (else l)))))))
+
+(define (controllers-list list controllers)
+  (cond ((null? controllers)
+        list)
+       ((list? (car controllers))
+        (assoc-set! (controllers-list list (cdr controllers)) (caar controllers) (cadar controllers)))
+       (else
+        (assoc-set! (controllers-list list (cdr controllers)) (gensym) (car controllers)))))
+
+(define activated-views '())
+
+(define (sort-views views-alist)
+  (sort views-alist
+       (lambda (v1 v2)
+         (< (view-priority (cdr v1)) (view-priority (cdr v2))))))
+
+(define (activate-view view)
+  (set! activated-views
+       (sort-views (assoc-set! activated-views (view-id view) view)))
+  view)
+
+(define (view-actived? view)
+  (and (assoc (view-id view) activated-views) #t))
+
+(define (view-priority-set! view priority)
+  ((record-modifier view-type 'priority) view priority)
+  (if (view-actived? view)
+      (set! activated-views (sort-views activated-views))))
+
+(define current-view #f)
+
+(define* (run-views #:optional (views activated-views))
+  (cond ((not (null? views))
+        (set! current-view (cdar views))
+        ;((view-body current-view))
+        (draw-meshes (view-meshes current-view))
+        (run-views (cdr views)))))
+
+(define (draw-meshes meshes)

   (cond ((not (null? meshes))
         (catch #t
   (cond ((not (null? meshes))
         (catch #t

-                 (lambda () (mesh-draw (car meshes)))
+                 (lambda () (mesh-draw (cdar meshes)))

                  (lambda (key . args) #f))
         (draw-meshes (cdr meshes)))))
 
                  (lambda (key . args) #f))
         (draw-meshes (cdr meshes)))))
 

-(define-macro (define-view name content)
-  `(begin
-     (hash-set! active-views ',name (lambda () (video:glmatrix-block ,content)))
-     ',name))
+
+;(define default-view (activate-view (make-view (lambda () #f))))

 
 
 ;;; Meshes
 
 
 ;;; Meshes


@@ -51,16 +118,15 @@
                      (display ">" port))))
                      
 
                      (display ">" port))))
                      
 

-(define mesh-constructor (record-constructor mesh-type))

 (define mesh? (record-predicate mesh-type))
 
 (define mesh? (record-predicate mesh-type))
 

-(define* (mesh proc #:optional mesh-type)
+(define* (make-mesh proc #:optional type)

   (apply
   (apply

-   mesh-constructor
+   (record-constructor mesh-type)

    (let ((px 0) (py 0) (pz 0)
         (ax 0) (ay 0) (az 0)
         (rx 0) (ry 0) (rz 0)
    (let ((px 0) (py 0) (pz 0)
         (ax 0) (ay 0) (az 0)
         (rx 0) (ry 0) (rz 0)

-        (id (gensym)) (type mesh-type)
+        (id (gensym))

         (properties '()))
      (let ((inner-properties
            (lambda ()
         (properties '()))
      (let ((inner-properties
            (lambda ()


@@ -128,13 +194,19 @@
 (define (mesh-property-set! mesh prop-name value)
   (((record-accessor mesh-type 'property-set!) mesh) prop-name value))
 
 (define (mesh-property-set! mesh prop-name value)
   (((record-accessor mesh-type 'property-set!) mesh) prop-name value))
 

-(define* (show mesh #:optional (view default-view))
-  (let ((id (mesh-inner-property mesh 'id)))
-    (if (not (hash-ref view id))
-       (hash-set! view id mesh))))
+(define* (show mesh #:optional (view current-view))
+  (let ((id (mesh-inner-property mesh 'id))
+       (table (view-meshes view)))
+    (if (not (assoc-ref table id))
+       (view-meshes-set! view (assoc-set! table id mesh))))
+  mesh)

 
 

-(define* (hide mesh #:optional (view default-view))
-  (hash-remove! view (mesh-inner-property mesh 'id)))
+(define* (hide mesh #:optional (view current-view))
+  (let ((id (mesh-inner-property mesh 'id))
+       (table (view-meshes view)))
+    (if (assoc-ref table id)
+       (view-meshes-set! view (assoc-remove! table id))))
+  mesh)

 
 (define* (translate mesh x y #:optional (z 0))
   (((record-accessor mesh-type 'translate) mesh) x y z)
 
 (define* (translate mesh x y #:optional (z 0))
   (((record-accessor mesh-type 'translate) mesh) x y z)


@@ -157,9 +229,9 @@
 
 ;;; Primitives
 
 
 ;;; Primitives
 

-(defmacro* primitive (proc #:optional type)
+(defmacro* define-primitive (proc #:optional type)

   `(lambda (. params)
   `(lambda (. params)

-     (let ((m (mesh (lambda (props) (apply ,proc ((@ (gacela utils) arguments-apply) ,proc props))) ,type)))
+     (let ((m (make-mesh (lambda (props) (apply ,proc ((@ (gacela utils) arguments-apply) ,proc props))) ,type)))

        (mesh-properties-set! m ((@ (gacela utils) arguments-calling) ,proc params))
        m)))
 
        (mesh-properties-set! m ((@ (gacela utils) arguments-calling) ,proc params))
        m)))
 


@@ -170,7 +242,7 @@
         (let ((origin (caar symbols))
               (dest (cadar symbols)))
           `(begin
         (let ((origin (caar symbols))
               (dest (cadar symbols)))
           `(begin

-             (define ,origin (primitive ,dest ',origin))
+             (define ,origin (define-primitive ,dest ',origin))

              (define-primitives ,@(cdr symbols)))))))
 
 (define-primitives
              (define-primitives ,@(cdr symbols)))))))
 
 (define-primitives


@@ -178,11 +250,11 @@
   (square video:draw-square))
 
 
   (square video:draw-square))
 
 

+;;; Adding extensions to the main loop
+(add-extension! run-views 10)
+
+

 (module-map (lambda (sym var)
              (if (not (eq? sym '%module-public-interface))
                  (module-export! (current-module) (list sym))))
            (current-module))
 (module-map (lambda (sym var)
              (if (not (eq? sym '%module-public-interface))
                  (module-export! (current-module) (list sym))))
            (current-module))

-
-
-;;; Adding extensions to the main loop
-(add-extension! draw-meshes 50)