Defining views with controllers and meshes

[gacela.git] / src / views.scm

diff --git a/src/views.scm b/src/views.scm
index f8e93e282417b80184c6a88780a13621b47a4d7c..b45fa91f4c24e387be36cb344b3ad6312bbd28e2 100644 (file)
--- a/src/views.scm
+++ b/src/views.scm
@@ -22,32 +22,110 @@
   #: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)
+(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* (view2 #:key (priority 0) . elements)
+  (let ((controllers '())
+       (meshes '()))
+    (define (f elements)
+      (cond ((not (null? elements))
+            (cond ((mesh? (car elements)) (set! meshes (cons (car elements) meshes)))
+                  ((procedure? (car elements)) (set! controllers (cons (car elements) controllers))))
+            (f (cdr elements)))))
+    (f elements)
+    (display controllers)
+    (newline)
+    (display meshes)
+    (newline)))
+
+(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)))))
 

-(add-extension! draw-meshes 50)

 
 

-(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

 
 (define mesh-type
   (make-record-type "mesh" 
 
 (define mesh-type
   (make-record-type "mesh" 

-                   '(draw translate turn rotate inner-properties inner-property properties properties-set! property property-set!)))
+                   '(draw translate turn rotate inner-properties inner-property properties properties-set! property property-set!)
+                   (lambda (record port)
+                     (format port "#<mesh: ~a" (mesh-inner-property record 'type))
+                     (for-each (lambda (x)
+                                 (cond (((@ (gacela utils) bound?) (cdr x))
+                                        (format port " ~a" x))))
+                               (mesh-properties record))
+                     (display ">" port))))
+                     

 
 

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

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

-(define (mesh proc)
+(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)


@@ -55,7 +133,7 @@
         (properties '()))
      (let ((inner-properties
            (lambda ()
         (properties '()))
      (let ((inner-properties
            (lambda ()

-             `((id . ,id) (x . ,px) (y . ,py) (z . ,pz) (ax . ,ax) (ay . ,ay) (az . ,az) (rx . ,rx) (ry . ,ry) (rz . ,rz)))))
+             `((id . ,id) (type . ,type) (x . ,px) (y . ,py) (z . ,pz) (ax . ,ax) (ay . ,ay) (az . ,az) (rx . ,rx) (ry . ,ry) (rz . ,rz)))))

        (list
        (lambda ()
          "draw"
        (list
        (lambda ()
          "draw"


@@ -101,6 +179,9 @@
 (define (mesh-draw mesh)
   (((record-accessor mesh-type 'draw) mesh)))
 
 (define (mesh-draw mesh)
   (((record-accessor mesh-type 'draw) mesh)))
 

+(define (mesh-inner-properties mesh)
+  (((record-accessor mesh-type 'inner-properties) mesh)))
+

 (define (mesh-inner-property mesh prop-name)
   (((record-accessor mesh-type 'inner-property) mesh) prop-name))
 
 (define (mesh-inner-property mesh prop-name)
   (((record-accessor mesh-type 'inner-property) mesh) prop-name))
 


@@ -110,36 +191,50 @@
 (define (mesh-properties-set! mesh new-properties)
   (((record-accessor mesh-type 'properties-set!) mesh) new-properties))
 
 (define (mesh-properties-set! mesh new-properties)
   (((record-accessor mesh-type 'properties-set!) mesh) new-properties))
 

-(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 (mesh-property mesh prop-name)
+  (((record-accessor mesh-type 'property) mesh) prop-name))
+
+(define (mesh-property-set! mesh prop-name value)
+  (((record-accessor mesh-type 'property-set!) mesh) prop-name value))

 
 

-(define* (hide mesh #:optional (view default-view))
-  (hash-remove! view (mesh 'inner-property 'id)))
+(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 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))
 
 (define* (translate mesh x y #:optional (z 0))

-  (mesh 'translate x y z)
+  (((record-accessor mesh-type 'translate) mesh) x y z)

   mesh)
 
 (define (turn mesh . params)
   mesh)
 
 (define (turn mesh . params)

-  (if (>= (length params) 3)
-      (apply mesh (cons 'turn params))
-      (mesh 'turn 0 0 (car params)))
+  (apply ((record-accessor mesh-type 'turn) mesh)
+        (if (>= (length params) 3)
+            params
+            (list 0 0 (car params))))

   mesh)
 
 (define (rotate mesh . params)
   mesh)
 
 (define (rotate mesh . params)

-  (if (>= (length params) 3)
-      (apply mesh (cons 'rotate params))
-      (mesh 'rotate 0 0 (car params)))
+  (apply ((record-accessor mesh-type 'rotate) mesh)
+        (if (>= (length params) 3)
+            params
+            (list 0 0 (car params))))

   mesh)
 
 
 ;;; Primitives
 
   mesh)
 
 
 ;;; Primitives
 

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

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

-     (let ((m (mesh (lambda (props) (apply ,proc ((@ (gacela utils) arguments-apply) ,proc props))))))
+     (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)))
 


@@ -150,7 +245,7 @@
         (let ((origin (caar symbols))
               (dest (cadar symbols)))
           `(begin
         (let ((origin (caar symbols))
               (dest (cadar symbols)))
           `(begin

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

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


@@ -158,6 +253,10 @@
   (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))))
 (module-map (lambda (sym var)
              (if (not (eq? sym '%module-public-interface))
                  (module-export! (current-module) (list sym))))