Random Bits of Open Code

Check-in [3e16b01508]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:First pass of multiapp
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:3e16b01508800f8d51a15f2a795e7a1f4870720a
User & Date: matt 2018-07-13 05:18:09
Context
2018-07-13
06:01
fleshed out raw basic gui for multiapp demo app teach-learn check-in: 7a7ed4401c user: matt tags: trunk
05:18
First pass of multiapp check-in: 3e16b01508 user: matt tags: trunk
2018-07-12
20:30
Cleaned up a bit check-in: 8808f212d2 user: mrwellan tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to a3d/propellor.scm.

8
9
10
11
12
13
14
15
16


17
18
19
20
21
22
23
24
25
26


27
28
29
30
31
32
33
..
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90

91
92
93
94
95
96
97

98

99
100
101
102
103
104
105
106
107
108
109




110
111
112
113

114
115
116

117
118
119
120
121
122
123
124
125
126
127
128
129

130
131
132
133
134
135
136
137
138
(define (rad->deg r)
  (* 180 (/ r *pi*)))


(define (airspin #!key (height 10)(convexity 10)(twist 90)(slices 100)(dia 60)(thickness 1))
  (conc "linear_extrude(height = " height ", center = false, convexity = " convexity ", twist = " twist ", slices = " slices ") {
    translate([" (- (/ thickness 2)) "," (- (/ dia 2)) ",0]) {
        square([" thickness "," (/ dia 2) "]);
    }


}
"))

(define (get var)
  (case var
    ((outer-r)  (/ 17 2))
    ((inner-r)  (/ 5.6 2))
    ((body-h)   15)
    ((shaft-a)  20)
    ((shaft-e)  120) ;; shaft elevation at top


    (else #f)))

(define (air-prop-blade)
  (let ((h 15))
    (rotate
     (vec 0 0 15)
     (union
................................................................................

(define (water-prop)
  (let ((h 15)
	(blade (lambda (angle)
		 (rotate (vec 0 0 angle)
			 (translate (vec 1 3 0)
				    (rotate (vec 0 0 180)
					    (airspin height: 10 twist: 75 dia: 40 thickness: 1.5)))))))
    (rotate
     (vec 0 0 15)
     (union
      (water-prop-hub)
      (blade 0)
      (blade 120)
      (blade 240)
      ))))

(define (pivot-assm #!optional (mode 'with-shaft))
  (let* ((shaft-a (get 'shaft-a))
	 (outer-r (get 'outer-r))
	 (inner-r (get 'inner-r))
	 (shaft-e (get 'shaft-e)) ;; elevation at bearing level

	 (bearing (lambda (hole)
		    (rotate (vec (- 90 shaft-a) 0 0)
			    (difference 
			     (cylinder 40 outer-r outer-r)
			     (if hole
				 (cylinder 42 inner-r inner-r)
				 '())))))

	 (bearing-loc (vec 0 8 77))

	 (arch    (lambda ()
		    (difference
		     (translate (vec 0 0 -40)
				(rotate (vec 90 0 0)
					(difference
					 (cylinder 10 shaft-e (- shaft-e 9))
					 (translate (vec 0 0 -1)(cylinder 12 (- shaft-e 10)(- shaft-e 10))))))
		     (translate (vec -200 -200 -200)(cube (vec 400 400 200)))))))
    (union
     ;; support arch
     (difference




      (union
       (arch)
       (translate (vec 0 0 0)(rotate (vec 0 0 180)(arch))))
      (translate bearing-loc (bearing #f)))

     (translate bearing-loc
		(bearing #t))
     (translate (vec (- 7 shaft-e) -60 0)(cube (vec 15 70 4)))

     (translate (vec (- shaft-e 15 7) -60 0)(cube (vec 15 70 4)))
     )))
	  
(define (assembly)
  (a3d
   (pov-include "colors" "shapes" "textures")
   "$fn=100;"
   (a3d-pov
    ;; (airspin height: 15 convexity: 5 twist: 30 slices: 100 dia: 200)
    ;; (rotate (vec 90 0 0)(air-prop-blade))
    ;; (air-prop-hub)
    (water-prop)
    ;; (pivot-assm)

    )
   ;; x y and z are not consistent with stuff inside a3d-pov
   ;; use left hand rule with z towards you
   (camera (vec->pov (vec 250 50 120))(vec->pov (vec 0 100 50)))
   (light  (vec->pov (vec 60 40 50)) 'white)))

(a3d->file 'povray   "propellor.pov"  assembly)
(a3d->file 'openscad "propellor.scad" assembly)
(exit)







|
<
>
>








|
|
>
>







 







|









|




>



|



>
|
>
|
|



|
|
<



>
>
>
>
|
|
|
|
>


<
>
|











|
>









8
9
10
11
12
13
14
15

16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
..
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111

112
113
114
115
116
117
118
119
120
121
122
123
124
125

126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
(define (rad->deg r)
  (* 180 (/ r *pi*)))


(define (airspin #!key (height 10)(convexity 10)(twist 90)(slices 100)(dia 60)(thickness 1))
  (conc "linear_extrude(height = " height ", center = false, convexity = " convexity ", twist = " twist ", slices = " slices ") {
    translate([" (- (/ thickness 2)) "," (- (/ dia 2)) ",0]) {
        "  "square([" thickness "," (/ dia 2) "]);

        " ;; " polygon(points=[[0,0],[100,0],[130,50],[30,50]]);"
    "}
}
"))

(define (get var)
  (case var
    ((outer-r)  (/ 17 2))
    ((inner-r)  (/ 5.6 2))
    ((body-h)   15)
    ((shaft-a)  -20)
    ((shaft-e)  110) ;; shaft elevation at top
    ((low-r)    200) ;; arch radius for low arch
    ((foot-l)    70) ;; foot for arches
    (else #f)))

(define (air-prop-blade)
  (let ((h 15))
    (rotate
     (vec 0 0 15)
     (union
................................................................................

(define (water-prop)
  (let ((h 15)
	(blade (lambda (angle)
		 (rotate (vec 0 0 angle)
			 (translate (vec 1 3 0)
				    (rotate (vec 0 0 180)
					    (airspin height: 10 twist: 75 dia: 60 thickness: 3)))))))
    (rotate
     (vec 0 0 15)
     (union
      (water-prop-hub)
      (blade 0)
      (blade 120)
      (blade 240)
      ))))

(define (pivot-assm #!optional (mode 'high)) ;; or low
  (let* ((shaft-a (get 'shaft-a))
	 (outer-r (get 'outer-r))
	 (inner-r (get 'inner-r))
	 (shaft-e (get 'shaft-e)) ;; elevation at bearing level
	 (foot-l  (get 'foot-l))
	 (bearing (lambda (hole)
		    (rotate (vec (- 90 shaft-a) 0 0)
			    (difference 
			     (cylinder 2 outer-r outer-r)
			     (if hole
				 (cylinder 42 inner-r inner-r)
				 '())))))
	 (bearing-h   (if (eq? mode 'high) 80 20))
	 (bearing-loc (vec 0 (if (eq? mode 'high) 0 (- 12 foot-l)) bearing-h))
	 (r           (if (eq? mode 'high) shaft-e (get 'low-r)))
	 (arch    (lambda (r)
		    ;;(difference
		     (translate (vec 0 0 -40)
				(rotate (vec 90 0 0)
					(difference
					 (cylinder 4 r (- r 3))
					 (translate (vec 0 0 -1)(cylinder 8 (- r 10)(- r 0)))))))))

    (union
     ;; support arch
     (difference
      (translate
       (vec 0
	    (if (eq? mode 'high) 0 (- 9 foot-l))
	    (if (eq? mode 'high) 4 (- -20 shaft-e)))
       (union
	(arch r)
	(translate (vec 0 0 0)(rotate (vec 0 0 180)(arch r)))))
      (translate bearing-loc (bearing #f))
      (translate (vec -400 -400 -400)(cube (vec 800 800 400))))
     (translate bearing-loc
		(bearing #t))

     (translate (vec (- 8 shaft-e) -65 0)(cube (vec 15 foot-l 4)))
     (translate (vec (- shaft-e 15 8) -65 0)(cube (vec 15 foot-l 4)))
     )))
	  
(define (assembly)
  (a3d
   (pov-include "colors" "shapes" "textures")
   "$fn=100;"
   (a3d-pov
    ;; (airspin height: 15 convexity: 5 twist: 30 slices: 100 dia: 200)
    ;; (rotate (vec 90 0 0)(air-prop-blade))
    ;; (air-prop-hub)
    (water-prop)
    ;; (pivot-assm 'low)
    ;; (translate (vec 0 70 0)(pivot-assm 'high))
    )
   ;; x y and z are not consistent with stuff inside a3d-pov
   ;; use left hand rule with z towards you
   (camera (vec->pov (vec 250 50 120))(vec->pov (vec 0 100 50)))
   (light  (vec->pov (vec 60 40 50)) 'white)))

(a3d->file 'povray   "propellor.pov"  assembly)
(a3d->file 'openscad "propellor.scad" assembly)
(exit)

Added multiapp/Makefile.

















































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

# Need to run as follows:
#
# CSC_OPTIONS="-I$PREFIX/include -L$PREFIX/lib" make deploy

SHELL = /bin/bash
CSCOPTS=
SRCFILES=src/gui.scm src/learn-teach.scm
DEPLOYSOFILES = $(SOFILES:src/%=deploytarg/%)
OFILES = $(SRCFILES:%.scm=%.o)
EXTRASOFILES = pkts.so dbi.so vg.so margs.so mtconfigf.so mtcommon.so mtdb.so iuputils.so
EXTRAS = $(EXTRASOFILES:%=deploytarg/%)
LINUX_EGGS=readline hostinfo
EGGS=simple-md5  apropos base64 regex-literals format regex-case test coops trace csv \
     dot-locking posix-utils posix-extras directory-utils tcp-server rpc csv-xml fmt \
     json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
     spiffy-directory-listing ssax srfi-42 sxml-serializer sxml-modifications srfi-42 matchable \
     crypt sha1 typed-records simple-exceptions iup canvas-draw sql-de-lite matchable

DPLYEGGS = $(EGGS:%=deploytarg/%.so)
DPLYLOGS = $(EGGS:%=eggs/%.log)
KEEP_INSTALLED=-keep-installed
# KEEP_INSTALLED=

all : multiapp
deploy : deploytarg/multiapp

src/%.o : src/%.scm
	csc  $(CSCOPTS) -J -c $<

# gotta have std eggs installed before installing our extra eggs
$(EXTRAS) : $(DPLYLOGS)

# src/%.so : src/%.scm
# 	csc $(CSCOPTS) -J -c $<
# 	cp src/$*.so $*.import.scm deploytarg

deploytarg/pkts.so : ../opensrc/pkts/pkts.scm
	cd ../opensrc/pkts;chicken-install -p $(PWD)/deploytarg -deploy

deploytarg/margs.so : ../opensrc/margs/margs.scm
	cd ../opensrc/margs;chicken-install -p $(PWD)/deploytarg -deploy

deploytarg/dbi.so : ../dbi/dbi.scm
	cd ../dbi;chicken-install -p $(PWD)/deploytarg -deploy

deploytarg/vg.so : ../vg/vg.scm
	cd ../vg;chicken-install -p $(PWD)/deploytarg -deploy

deploytarg/mtdb.so deploytarg/mtconfigf.so deploytarg/mtcommon.so : ../opensrc/mtutils/*.scm
	cd ../opensrc/mtutils;chicken-install -p $(PWD)/deploytarg -deploy

deploytarg/%.so : eggs/%.log

eggs/%.log :
	chicken-install -p deploytarg -deploy -keep-installed $* > eggs/$*.log 2>&1 

deploytarg/multiapp : $(EXTRAS) $(DPLYLOGS) $(OFILES) src/multiapp.scm src/learn-teach.scm
	csc -deploy $(OFILES) src/multiapp.scm -o deploytarg
	mv deploytarg/deploytarg deploytarg/multiapp

multiapp : $(OFILES) src/multiapp.scm
	csc $(CSCOPTS) $(OFILES) src/multiapp.scm -o multiapp
	if [[ -e $(PWD)/../opensrc/mtutils ]]; then \
	  cd ../opensrc ;\
	  $(withproxy) fossil up ;\
          cd mtutils; make ;\
        fi
# deploytarg/apropos.so : Makefile
# 	chicken-install -p deploytarg -deploy $(EGGS)


Added multiapp/src/db.scm.



















































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(declare (unit db))


(module db
    (open-db)

(import scheme chicken)

(define (open-db)
  (print "got here")
  #t)


)

Added multiapp/src/gui.scm.













































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(declare (unit gui))


(module gui
    (
     main-menu
     )

(import scheme chicken)
(use (prefix iup iup:) canvas-draw pkts posix vg)

(define (main-menu curr-obj)
  (iup:menu
   (iup:menu-item "File" (iup:menu
			  (iup:menu-item
			   "Open"
			   action: (lambda (obj)
				     (let* ((area-name (iup:textbox #:expand "HORIZONTAL"))
					    (fd        (iup:file-dialog #:dialogtype "DIR"))
					    (top       (iup:show fd #:modal? "YES")))
				       (iup:attribute-set! curr-obj "VALUE"
							   (iup:attribute fd "VALUE"))
				       (iup:destroy! fd))))
			  (iup:menu-item
			   "Exit"
			   action: (lambda (obj)(exit 0)))))))
)

Added multiapp/src/learn-teach.scm.



































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
;;======================================================================
;; Copyright 2006-2016, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(declare (unit learn-teach))


(module learn-teach
    (
     make-tab
     read-learn-teach-config
     write-learn-teach-config
     make-tab
     )

(import scheme chicken data-structures)
(use (prefix iup iup:)
     srfi-69 regex typed-records files matchable
     canvas-draw pkts posix vg simple-exceptions
     (prefix mtconfigf configf:)
     (prefix mtcommon  common:)
     (prefix iuputils  iuputils:)
     (prefix mtdb      mtdb:)
     (prefix iuputils  iuputils:)
     srfi-18
     call-with-environment-variables)

;; (use trace) ;; see trace at end of file

(defstruct learn-teach ;; rename this! it is confusing due to collision with module name!
  filters
  row-order
  col-order
  (last-area-update 0)
  (areas         (make-hash-table)) ;; area-name -> adat
  (area-ids      (make-hash-table)) ;; area-id   -> adat
  (runs          (make-vector 0))   ;; vector of runs by column number
  (disp-runs     (make-vector 0))   ;; the runs to actually display
  (runs-by-label (make-hash-table)) ;; hash of runs by label e.g. area\ntarg\nrunname
  (left-index    (make-hash-table)) ;; index of test/item-path => row-num
  (max-row       1)
  ;; gui objects
  ;; (top-controls #f)
  (filter-tree  #f)
  (sessions-matrix #f)
  ;; filters
  (bundle-filter #f)
  (area-filter   #f)
  (target-filter #f)
  (run-name-filter #f)
  (test-filter   #f)
  (filter-prev-values (make-hash-table))
  ;; mapped paths - updating the tree object can be slow, track the paths applied here
  (mapped-paths  (make-hash-table))
  config
  reset-fn
  )

(define (read-learn-teach-config #!key (infile #f))
  (let* ((fname (or infile (if (common:windows?) ;; (get-environment-variable "HOME")
			       "learn-teach.config" ;; we must be on windows
			       (conc (get-environment-variable "HOME") "/.learn-teach/config")
			       ))))
    (if (file-exists? fname)
	(begin
	  (print "Loading config file " fname)
	  (configf:read-config fname #f #t))
	(make-hash-table))))

(define (read-areas-config #!key (infile #f))
  (let* ((fname (or infile (if (common:windows?) ;; (get-environment-variable "HOME")
			       "areas.config" ;; we must be on windows
			       (conc (get-environment-variable "HOME") "/.learn-teach/areas.config")
			       ))))
    (if (file-exists? fname)
	(begin
	  (print "Loading config file " fname)
	  (configf:read-config fname #f #t))
	(make-hash-table))))

;; need also write-config which does read-modify-write but it needs to be fixed
;; for now do a for-each write
;;
(define (write-learn-teach-config cfgdat #!key (infile #f))
  (let* ((learn-teachdir (conc (get-environment-variable "HOME") "/.learn-teach"))
	 (fname (or infile (conc learn-teachdir "/config"))))
    (if (not (directory-exists? learn-teachdir))(create-directory learn-teachdir #t))
    (configf:write-config cfgdat fname)))

(define signal-reset-exception 
   (make-exception "Reset request recived." 'reset-request-exn))

(define (reset-request cmd)
  (let ((val #f)) ;; force redraw flag 
    (lambda (cmd)
      (case cmd
	((reset)(set! val #t)) ;; fast exit the loops
	((go)   (set! val #f)) ;; allow the loops to run
	((curr) val)))))

(define (make-tab)
  (let* ((bundle-filter-tb   (iup:textbox value: "%"  expand: "HORIZONTAL" action: (lambda (obj a b)(reset-request 'reset))))
	;; (top-controls (iup:hbox
	;; 		(iup:hbox
	;; 		 (iup:vbox (iup:label "row")(iup:label "col"))
	;; 		 (iup:vbox (iup:label "target")(iup:label "test"))
	;; 		 (iup:vbox (iup:label "run-name")(iup:label "items")))))
	 (subjects-tree  (iup:treebox
			#:value 0
			#:title "Subjects" ;;  was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute."
			#:expand "YES"
			#:addexpanded "YES"
			#:size "10x"
			#:selection-cb
			(lambda (obj id state)
			  (let* ((path (iuputils:tree-node->path obj id)) ;; will get called twice - click and release
				 (plen (length path)))
			    (reset-request 'reset) ;; flag matrix draw to start over and not finish current draw
			    ;; (print "selection-cb state: " state)
			    (if (<= plen 1)
				(begin
				  (iup:attribute-set! bundle-filter-tb "VALUE" "%")
				  ))
			    (if (> plen 1)(iup:attribute-set! bundle-filter-tb "VALUE" (list-ref path 1)))
			    path))))
	 (sessions-matrix  (iup:matrix
			 #:alignment1 "ALEFT"
			 ;; #:expand "YES" ;; "HORIZONTAL"
			 #:scrollbar "YES"
			 #:numcol 100
			 #:numlin 200
			 #:numcol-visible 8 ;; (min 8)
			 #:numlin-visible 20
			 #:click-cb
			 (lambda (obj row col status)
			   (cond
			    ((eq? col 0)
			     (let* ((full-test-name (iup:attribute obj (conc row ":0")))
				    (new-test-patt (conc full-test-name "/%")))
			       (iup:attribute-set! bundle-filter-tb  "VALUE" new-test-patt)
			       )))
			   status)))
	 (learn         (iup:split
			 #:orientation "VERTICAL"
			 #:value 100
			 subjects-tree
			 sessions-matrix))
	 (teach         (iup:split
			 #:orientation "VERTICAL"
			 #:value 100
			 (iup:textbox)
			 (iup:textbox)))
	 (gui           (let ((side-tabs (iup:tabs
					  #:tabtype "LEFT"
					  learn
					  teach)))
			  (iup:attribute-set! side-tabs "TABTITLE0" "Learn")
			  (iup:attribute-set! side-tabs "TABTITLE1" "Teach")
			  side-tabs))
	 (cfgdat       (read-learn-teach-config))
	 (mydata       #f) ;; hash table with pointers to all the stuff we need to keep track of, could use a struct but not sure I can safely test it for being compatible
	 (learn-teach-dat   (make-learn-teach ;; we store the state private to this tab in here
			;; top-controls:  top-controls
			subjects-tree:   subjects-tree
			sessions-matrix:  sessions-matrix
			bundle-filter: bundle-filter-tb
			config:        cfgdat
			reset-fn:      reset-request
			))
	 ;; the mydat object can be searched for in alldats
	 (updater      (let ((last-up 0)) ;; last time the matrix was updated
			 (lambda (mytabnum currtabnum alldats)
			   (let* ((mydat   (hash-table-ref/default alldats mytabnum #f))
				  (currsec (current-seconds))
				  (tdelta  (- currsec last-up)))
			     (cond
			      ((not mydat) ;; first time through we init mydat in alldats
			       (print "INFO: init tab " mytabnum)
			       (let ((newdat (make-hash-table)))
				 (hash-table-set! alldats mytabnum newdat)
				 (set! mydata newdat)
				 (hash-table-set! newdat 'areas (make-hash-table))))
			      ((not mydata) ;; have mydat but it is not available in mydata
			       (print "INFO: save tab dat")
			       (set! mydata mydat)) ;; this will not ever get hit until there is a finder of shared dat
			      ;; refresh any needed area data if it has been more than 1 second since the last update
			      ((> tdelta 3) ;; minumum of every four seconds update the matrix
			       (print "INFO: update matrix curr " currsec " last " last-up " tdelta " tdelta)
			       ;; (update-matrix learn-teach-dat tdelta)
			       (set! last-up currsec))
			      ((> currsec (+ (learn-teach-last-area-update learn-teach-dat) 3))
			       (print "INFO: update one area")
			       ;; (print "currsec: " currsec " last area update: " (learn-teach-last-area-update learn-teach-dat))
			       (learn-teach-last-area-update-set! learn-teach-dat currsec)
			       ) ;; look for one area that is stale and refresh it
			      (else
			       ;; here we update the matrix?
			       (print "INFO: spare time, update matrix  last " last-up " tdelta " tdelta)
			       ;;(update-matrix learn-teach-dat tdelta)
			       (set! last-up currsec)))))))
	 (tabdat       (make-hash-table)))
    (values gui updater tabdat)))

(define (sync #!key (keep-going #f)) ;; keep-going is seconds to keep going
  (let* ((cfgdat     (read-learn-teach-config))
	 (learn-teach-dat (make-learn-teach))
	 (start-time (current-seconds))
	 (end-time   (+ start-time (or keep-going 0))))
    (let loop ((curr-time start-time))
      ;;(update-one-area cfgdat learn-teach-dat)
      (learn-teach-last-area-update-set! learn-teach-dat curr-time)
      (if (> end-time curr-time)
	  (begin
	    (thread-sleep! 0.1)
	    (loop (current-seconds)))))))


)

Added multiapp/src/multiapp.scm.



































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
;;======================================================================
;; Copyright 2006-2017, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.
;;======================================================================

(define (toplevel-command . a) #f)
(use (prefix iup iup:) canvas-draw pkts posix vg typed-records srfi-18 readline)

(import canvas-draw-iup)

(require-library margs)

(declare (uses gui))
(declare (uses learn-teach))
(import (prefix gui gui:)
	(prefix mtdb mtdb:)
	(prefix learn-teach learn-teach:))

(define help "Usage: multiapp [[command] args ...]
  Where the optional command is:
    help          : this help
    repl          : start up a repl
    multiapp     : start the gui (default)
")

;; get a tab
;;
(define (get-tab obj proc tabnum)
  (let-values (((guiobj updater tabdat)
		(proc)))
    (hash-table-set! (main-tabs obj) tabnum updater) ;; tab updater
    (hash-table-set! (main-dats obj) tabnum tabdat)  ;; tab data store (could just use closure from within updater but this allows the tab to potentially share data with other tabs)
    (if (> tabnum (main-maxtab obj))(main-maxtab-set! obj tabnum))
    guiobj))
    
;; pack the tabs
;;
(define (pack-tabs obj)
  (let ((tabs (iup:tabs
	       (get-tab obj learn-teach:make-tab 0)
	       ;; (get-tab obj ftf:make-tab    1)
	       )))
    (iup:attribute-set! tabs "TABTITLE0" "LearnTeach")
    ;; (iup:attribute-set! tabs "TABTITLE1" "ftfplan")
    tabs))

(defstruct main
  id
  (currtab 0)                  ;; this is the tab the user can see
  (nexttab 0)                  ;; for updating
  (maxtab  0)                  ;; highest tab number, can we get this by querying the iup:tabs object?
  (tabs    (make-hash-table))  ;; tabnum -> tab updater
  (dats    (make-hash-table))  ;; tabnum -> tabs dat (any object the tab wants to store)
  (timer   (iup:timer))        ;;
  (running #f)                 ;; is the updater running
  ;; (cfg     #f)
  )

(define (run-updaters obj)
  (let loop ()
    (let* ((curr-tab (main-currtab obj))
	   (next-tab (main-nexttab obj))
	   (tabs     (main-tabs    obj))
	   (updater  (hash-table-ref/default tabs next-tab #f))
	   (max-tab  (main-maxtab  obj)))
      ;; call the updater
      (print "INFO: running updater for tab " curr-tab)
      (if updater (updater next-tab curr-tab (main-dats obj))) 
      (main-nexttab-set! obj (if (>= next-tab max-tab) 0 (+ next-tab 1))))
    (thread-sleep! 0.25)
    (loop)))

(define (run-updater obj)
  (let* ((curr-tab (main-currtab obj))
	 (next-tab (main-nexttab obj))
	 (tabs     (main-tabs    obj))
	 (updater  (hash-table-ref/default tabs next-tab #f))
	 (max-tab  (main-maxtab  obj)))
    ;; call the updater
    (if (not (main-running obj))
	(begin
	  (main-running-set! obj #t)
	  (print "INFO: running updater for tab " curr-tab)
	  (if updater (updater next-tab curr-tab (main-dats obj))) 
	  (main-nexttab-set! obj (if (>= next-tab max-tab) 0 (+ next-tab 1)))
	  (main-running-set! obj #f)))))

(define (main)
  (let ((obj (make-main)))
    (iup:show
     (iup:dialog
      #:title "The Multiapp"
      #:menu (gui:main-menu obj)
      (pack-tabs obj)))
    ;; (thread-start! (make-thread (lambda ()(run-updaters obj))))
    (iup:callback-set! (main-timer obj) "ACTION_CB"
		       (lambda (time-obj)(run-updater obj)))
    (iup:attribute-set! (main-timer obj) "TIME" 300) ;; (or (configf:lookup *configdat* "multiapp" "poll-interval") "1000"))
    (iup:attribute-set! (main-timer obj) "RUN" "YES")
    ))

(let ((multiapprc (conc (get-environment-variable "HOME") "/.multiapprc")))
  (if (file-exists? multiapprc)
      (load multiapprc)))

(let* ((args     (cdr (argv)))
       (cmd      (if (null? args) 'multiapp (string->symbol (car args))))
       (params   (if (> (length args) 1) (cdr args) '())))
  (case cmd
    ((multiapp)
     (main)
     (iup:main-loop))
;; ((sync) ;; move this to a separate executable which does not load iup
;;  (if (null? params)
;; 	 (mtview:sync)
;; 	 (let* ((run-time   (* 3600 (or (string->number (car params)) 1))))
;; 	   (mtview:sync keep-going: run-time))))
    ((repl)
     (install-history-file (get-environment-variable "HOME") ".multiapp_history")
     (current-input-port (make-readline-port "multiapp> "))
     (repl))
    (else
     (print help))))