Random Bits of Open Code

Check-in [55d3f9bc92]
Login

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

Overview
Comment:Cleaned up time slots view/edit
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:55d3f9bc920eceb9368b85dc4b4e83bc7fa86b50
User & Date: matt 2018-08-08 02:27:52
Context
2018-08-08
05:47
Added sync file and preped to use it. check-in: dbd18f41a2 user: matt tags: trunk
02:27
Cleaned up time slots view/edit check-in: 55d3f9bc92 user: matt tags: trunk
2018-08-07
22:08
nada check-in: aa8a1b0e9f user: mrwellan tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to multiapp/apps/learn-teach/learn-teach.scm.

351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
...
374
375
376
377
378
379
380



























381
382
383
384
385
386
387
388
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
...
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
...
874
875
876
877
878
879
880



























881
882
883
884
885
886
887
...
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
....
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
....
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079

1080
1081
1082
1083
1084
1085
1086

;;======================================================================
;; Time slots
;;======================================================================

;; fill in the time-slots with my time-slots
;;
(define (get-and-fill-time-slots time-slots user-name)
  (let* ((my-apkts (get-current-time-slots user: user-name))
	 (rownum   1))
    (for-each
     (lambda (pkt)
       (let* ((datetime (alist-ref 'datetime pkt))
	      (Z        (alist-ref 'Z pkt))
	      (parts    (append (string-split datetime) '(#f #f #f #f)))
................................................................................
     my-apkts)
    (iup:attribute-set! time-slots "FITTOTEXT" "C1")
    (iup:attribute-set! time-slots "FITTOTEXT" "C2")
    (iup:attribute-set! time-slots "FITTOTEXT" "C3")
    (iup:attribute-set! time-slots "REDRAW" "YES")
    time-slots))




























(define (save-time-slot time-slots date-edit-box time-edit-box day-edit-box tzone-edit-box id-edit-box)
  (let* ((date  (iup:attribute date-edit-box  "VALUE"))
	 (time  (iup:attribute time-edit-box  "VALUE"))
	 (day   (iup:attribute day-edit-box   "VALUE"))
	 (tzone (iup:attribute tzone-edit-box "VALUE"))
	 (id    (iup:attribute id-edit-box    "VALUE"))
	 (my-id (get-my-id))
	 (plist `((app      .  "tnl")
................................................................................
		  (tutor    .  ,my-id))))
    (if (valid-date date)
	(if (valid-time time)
	    (pkts:write-alist->pkt learn-teach-pkts-dir plist pktspec: pkt-spec ptype: 'tslot)
	    (iup:attribute-set! time-edit-box "BGCOLOR" "255 200 255"))
	(iup:attribute-set! date-edit-box "BGCOLOR" "255 200 255"))
    (load-pkts)
    (get-and-fill-time-slots time-slots (current-user-name))
    ))

;;======================================================================
;; Category, subject and level
;;======================================================================

(define (valid-category category)
................................................................................
					 (subj (if (> plen 2)(caddr path) #f)) ;; have at least the subj
					 (lev  (if (> plen 3)(cadddr path) #f))) ;; have at least the level
				    (if cat  (iup:attribute-set! category-edit-box "VALUE" cat))
				    (if subj (iup:attribute-set! subject-edit-box  "VALUE" subj))
				    (if lev  (iup:attribute-set! level-edit-box    "VALUE" lev))
				    (if lev  (iup:attribute-set! details-edit-box  "VALUE" (hash-table-ref entries (conc cat "/" subj "/" lev))))
				    path))))
	    (time-slots   (get-and-fill-time-slots
			   (gui:fill-matrix-headings
			    (iup:matrix
			     ;; #:expand "YES"
			     #:alignment "ALEFT"
			     #:resizematrix "YES"
			     #:scrollbar "YES"
			     #:numcol 3
................................................................................
			     #:numlin 20
			     #:numlin-visible "8"
			     #:click-cb (lambda (obj row col value) #f)
			     )
			    '("Id" "Date" "Time" "Week Day")
			    fit-text: #t)
			   (current-user-name)))



























	    (update-day     (lambda (obj cnum val)(print "Got day=" val)))
	    (update-time    (lambda (obj cnum val)
			      (iup:attribute-set! time-edit-box "BGCOLOR"
						  (if (valid-time val)
						      "255 255 255"
						      "255 200 255"))))
	    (update-date    (lambda (obj cnum val)
................................................................................
	    (update-zone    (lambda (obj cnum val)(print "Got tzone=" val)))
	    (update-id      (lambda (obj cnum val)(print "Got id=" val)))
	    (date-edit-box  (iup:textbox action: update-date expand: "HORIZONTAL" value: (time->string (seconds->local-time (current-seconds)) "%Y/%m/%d")))
	    (time-edit-box  (iup:textbox action: update-time expand: "HORIZONTAL" value: (time->string (seconds->local-time (current-seconds)) "%H:00")))
	    (day-edit-box   (iup:textbox action: update-day  expand: "HORIZONTAL" value: (time->string (seconds->local-time (current-seconds)) "%a")))
	    (tzone-edit-box (iup:textbox action: update-zone expand: "HORIZONTAL" value: (time->string (seconds->local-time (current-seconds)) "%Z")))
	    (id-edit-box    (iup:textbox action: update-id   expand: "HORIZONTAL"))
	    (add-time-slot  (lambda (obj)(save-time-slot time-slots date-edit-box time-edit-box day-edit-box tzone-edit-box id-edit-box)))
	    ;; (pp my-apkts)))))
	    (delete-time-slot (lambda (obj) (print "Got here.")))
	    (add/edit-slot  (iup:frame
			     title: "Add/Edit Time Slots"
			     ;; expand: "YES"
			     (iup:vbox
			      (iup:gridbox
................................................................................
			       ;; )
			      )
			     
			     (iup:frame
			      ;; (iup:label  "Specify Your Time Slots" expand: "HORIZONTAL" fontsize: "13" alignment: "ACENTER")
			      title: "      Specify Your Time Slots" fontsize: "13"
			      (iup:vbox
			       time-slots
			       add/edit-slot)))
			    ))
	    (help          (help-drawing))
	    (config        (make-config-tab cfgdat))
	    (gui           (let ((side-tabs (iup:tabs
					     #:tabtype "LEFT"
					     (car help)
................................................................................
				  ;;(update-matrix learn-teach-dat tdelta)
				  #f))))))
	    (tabdat       (make-hash-table))
	    )
    (hash-table-set! data 'sessions-matrix sessions-matrix)
    (hash-table-set! data 'subjects-tree   subjects-tree)
    (thread-start! (make-thread (lambda () ;; need to build up the tree *after* it has been "shown"
				  (thread-sleep! 2)
				  (get-and-fill-class-entries subjects-tree sessions-matrix data update-tree: #t)
				  (get-and-fill-my-subjects my-subjects-tree my-subjects (current-user-name) data update-tree: #t))))

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







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|







 







|







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|







 







|







 







|

|
>







351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
...
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
...
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
...
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
...
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
...
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
....
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
....
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141

;;======================================================================
;; Time slots
;;======================================================================

;; fill in the time-slots with my time-slots
;;
#;(define (get-and-fill-time-slots time-slots user-name)
  (let* ((my-apkts (get-current-time-slots user: user-name))
	 (rownum   1))
    (for-each
     (lambda (pkt)
       (let* ((datetime (alist-ref 'datetime pkt))
	      (Z        (alist-ref 'Z pkt))
	      (parts    (append (string-split datetime) '(#f #f #f #f)))
................................................................................
     my-apkts)
    (iup:attribute-set! time-slots "FITTOTEXT" "C1")
    (iup:attribute-set! time-slots "FITTOTEXT" "C2")
    (iup:attribute-set! time-slots "FITTOTEXT" "C3")
    (iup:attribute-set! time-slots "REDRAW" "YES")
    time-slots))

;; fill in the time-slots with my time-slots
;;
(define (get-and-fill-time-slots-tree time-slots-tree user-name)
  (let* ((my-apkts    (get-current-time-slots user: user-name))
	 (sorted-pkts (sort my-apkts (lambda (a b)(> (stdtime->seconds (alist-ref 'datetime a))
						     (stdtime->seconds (alist-ref 'datetime b))))))
	 (rownum      1))
    (for-each
     (lambda (pkt)
       (let* ((datetime   (alist-ref 'datetime pkt))
	      (Z          (alist-ref 'Z pkt))
	      (parts      (append (string-split datetime) '(#f #f #f #f))) ;; 2018/07/25 08:00 MST
	      (datestr    (list-ref parts 0))
	      (timestr    (list-ref parts 1))
	      (tz         (list-ref parts 2))
	      (timeval    (string->time datetime std-time-def)) ;; (string->time datestr "%Y/%m/%d"))
	      (day        (time->string timeval "%a"))
	      (day-time   (time->string timeval "%d %H:%M")) ;; (if timeval (time->day timeval) "-"))
	      (year       (time->string timeval "%Y"))
	      (month      (time->string timeval "%b"))
	      )
	 ;; (tztimeday  (conc tz " " timestr " " day)));; (time->string timeval "%Z %H:%M %a")))
	 ;; (match-let (((y m d)(string-split datestr "/")))
	 (tree-add-node time-slots-tree "Time Slots" `(,tz ,year ,month ,day ,day-time))))
     sorted-pkts)
    time-slots-tree))

(define (save-time-slot time-slots-tree date-edit-box time-edit-box day-edit-box tzone-edit-box id-edit-box)
  (let* ((date  (iup:attribute date-edit-box  "VALUE"))
	 (time  (iup:attribute time-edit-box  "VALUE"))
	 (day   (iup:attribute day-edit-box   "VALUE"))
	 (tzone (iup:attribute tzone-edit-box "VALUE"))
	 (id    (iup:attribute id-edit-box    "VALUE"))
	 (my-id (get-my-id))
	 (plist `((app      .  "tnl")
................................................................................
		  (tutor    .  ,my-id))))
    (if (valid-date date)
	(if (valid-time time)
	    (pkts:write-alist->pkt learn-teach-pkts-dir plist pktspec: pkt-spec ptype: 'tslot)
	    (iup:attribute-set! time-edit-box "BGCOLOR" "255 200 255"))
	(iup:attribute-set! date-edit-box "BGCOLOR" "255 200 255"))
    (load-pkts)
    (get-and-fill-time-slots-tree time-slots-tree (current-user-name))
    ))

;;======================================================================
;; Category, subject and level
;;======================================================================

(define (valid-category category)
................................................................................
					 (subj (if (> plen 2)(caddr path) #f)) ;; have at least the subj
					 (lev  (if (> plen 3)(cadddr path) #f))) ;; have at least the level
				    (if cat  (iup:attribute-set! category-edit-box "VALUE" cat))
				    (if subj (iup:attribute-set! subject-edit-box  "VALUE" subj))
				    (if lev  (iup:attribute-set! level-edit-box    "VALUE" lev))
				    (if lev  (iup:attribute-set! details-edit-box  "VALUE" (hash-table-ref entries (conc cat "/" subj "/" lev))))
				    path))))
	    #;(time-slots   (get-and-fill-time-slots
			   (gui:fill-matrix-headings
			    (iup:matrix
			     ;; #:expand "YES"
			     #:alignment "ALEFT"
			     #:resizematrix "YES"
			     #:scrollbar "YES"
			     #:numcol 3
................................................................................
			     #:numlin 20
			     #:numlin-visible "8"
			     #:click-cb (lambda (obj row col value) #f)
			     )
			    '("Id" "Date" "Time" "Week Day")
			    fit-text: #t)
			   (current-user-name)))
	    (time-slots-tree (iup:treebox
				#:value 0
				;; #:name "Subjects"
				#:title "Time Slots" ;;  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* ((entries   (get-add-ht data 'my-times))
					 (path      (iuputils:tree-node->path obj id)) ;; will get called twice - click and release
					 (plen      (length path))
					 (tz        (if (> plen 1)(list-ref path 1) #f))
					 (year      (if (> plen 2)(list-ref path 2) #f))
					 (month     (if (> plen 3)(list-ref path 3) #f))
					 (day       (if (> plen 4)(list-ref path 4) #f))
					 (date-time (if (> plen 5)(list-ref path 5) #f))
					 (mth-num   (if month (time->string (string->time month "%b") "%m") #f))
					 (d-n-t     (if date-time (string-split date-time) #f))
					 )
				    (if tz    (iup:attribute-set! tzone-edit-box "VALUE" tz))
				    (if day   (iup:attribute-set! day-edit-box  "VALUE" day))
				    (if d-n-t
					(begin
					  (iup:attribute-set! date-edit-box "VALUE" (conc year "/" mth-num "/" (car d-n-t)))
					  (iup:attribute-set! time-edit-box  "VALUE" (cadr d-n-t))))
				    path))))
	    (update-day     (lambda (obj cnum val)(print "Got day=" val)))
	    (update-time    (lambda (obj cnum val)
			      (iup:attribute-set! time-edit-box "BGCOLOR"
						  (if (valid-time val)
						      "255 255 255"
						      "255 200 255"))))
	    (update-date    (lambda (obj cnum val)
................................................................................
	    (update-zone    (lambda (obj cnum val)(print "Got tzone=" val)))
	    (update-id      (lambda (obj cnum val)(print "Got id=" val)))
	    (date-edit-box  (iup:textbox action: update-date expand: "HORIZONTAL" value: (time->string (seconds->local-time (current-seconds)) "%Y/%m/%d")))
	    (time-edit-box  (iup:textbox action: update-time expand: "HORIZONTAL" value: (time->string (seconds->local-time (current-seconds)) "%H:00")))
	    (day-edit-box   (iup:textbox action: update-day  expand: "HORIZONTAL" value: (time->string (seconds->local-time (current-seconds)) "%a")))
	    (tzone-edit-box (iup:textbox action: update-zone expand: "HORIZONTAL" value: (time->string (seconds->local-time (current-seconds)) "%Z")))
	    (id-edit-box    (iup:textbox action: update-id   expand: "HORIZONTAL"))
	    (add-time-slot  (lambda (obj)(save-time-slot time-slots-tree date-edit-box time-edit-box day-edit-box tzone-edit-box id-edit-box)))
	    ;; (pp my-apkts)))))
	    (delete-time-slot (lambda (obj) (print "Got here.")))
	    (add/edit-slot  (iup:frame
			     title: "Add/Edit Time Slots"
			     ;; expand: "YES"
			     (iup:vbox
			      (iup:gridbox
................................................................................
			       ;; )
			      )
			     
			     (iup:frame
			      ;; (iup:label  "Specify Your Time Slots" expand: "HORIZONTAL" fontsize: "13" alignment: "ACENTER")
			      title: "      Specify Your Time Slots" fontsize: "13"
			      (iup:vbox
			       time-slots-tree
			       add/edit-slot)))
			    ))
	    (help          (help-drawing))
	    (config        (make-config-tab cfgdat))
	    (gui           (let ((side-tabs (iup:tabs
					     #:tabtype "LEFT"
					     (car help)
................................................................................
				  ;;(update-matrix learn-teach-dat tdelta)
				  #f))))))
	    (tabdat       (make-hash-table))
	    )
    (hash-table-set! data 'sessions-matrix sessions-matrix)
    (hash-table-set! data 'subjects-tree   subjects-tree)
    (thread-start! (make-thread (lambda () ;; need to build up the tree *after* it has been "shown"
				  (thread-sleep! 1)
				  (get-and-fill-class-entries subjects-tree sessions-matrix data update-tree: #t)
				  (get-and-fill-my-subjects my-subjects-tree my-subjects (current-user-name) data update-tree: #t)
				  (get-and-fill-time-slots-tree time-slots-tree (get-my-id)))))
    (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))))