From 2c3c0bff524bdc8365f0c5e52b1b6a7d21e3099f Mon Sep 17 00:00:00 2001 From: Javier Sancho Date: Sun, 2 Sep 2012 14:02:26 +0200 Subject: [PATCH] Defining views --- src/utils.scm | 17 +++++++++++++++++ src/views.scm | 33 ++++++++++++++++++++------------- 2 files changed, 37 insertions(+), 13 deletions(-) diff --git a/src/utils.scm b/src/utils.scm index 015de6b..eb20531 100644 --- a/src/utils.scm +++ b/src/utils.scm @@ -143,3 +143,20 @@ (optional-arguments-apply args values) (keyword-arguments-apply args values) (rest-arguments-apply args values)))) + + +;;; 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)))) diff --git a/src/views.scm b/src/views.scm index 2fc44a8..052442b 100644 --- a/src/views.scm +++ b/src/views.scm @@ -26,19 +26,26 @@ (define view-type (make-record-type "view" - '(id controllers meshes priority) + '(id body meshes priority) (lambda (record port) - (format port "#" - (length (hash-map->list (lambda x x) (view-controllers record))) - (length (hash-map->list (lambda x x) (view-meshes record))))))) + (format port "#" + (length (view-meshes record)))))) -(define* (make-view #:optional (priority 0)) ((record-constructor view-type) (gensym) (make-hash-table) (make-hash-table) priority)) +(define (make-view body meshes) ((record-constructor view-type) (gensym) body meshes 0)) (define view? (record-predicate view-type)) (define view-id (record-accessor view-type 'id)) -(define view-controllers (record-accessor view-type 'controllers)) +(define view-body (record-accessor view-type 'body)) (define view-meshes (record-accessor view-type 'meshes)) (define view-priority (record-accessor view-type 'priority)) +(define-macro (view meshes . body) + `(make-view + ,(cond ((null? body) `(lambda () #f)) + (else `(lambda () ,@body))) + (map (lambda (m) + `(,(mesh-inner-property m 'id) . ,m)) + meshes))) + (define activated-views '()) (define (sort-views views-alist) (sort views-alist @@ -60,18 +67,18 @@ (define* (run-views #:optional (views activated-views)) (cond ((not (null? views)) ; controllers go here - (draw-meshes (hash-map->list (lambda (k v) v) (view-meshes (cdar views)))) + (draw-meshes (view-meshes (cdar views))) (run-views (cdr views))))) (define (draw-meshes meshes) (cond ((not (null? meshes)) (catch #t - (lambda () (mesh-draw (car meshes))) + (lambda () (mesh-draw (cdar meshes))) (lambda (key . args) #f)) (draw-meshes (cdr meshes))))) -(define default-view (activate-view (make-view))) +;(define default-view (activate-view (make-view))) ;;; Meshes @@ -216,11 +223,11 @@ (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)) - - -;;; Adding extensions to the main loop -(add-extension! run-views 10) -- 2.39.5