FoAM/scheduling
FoAM
/
scheduling
12
0
Fork 0
Code Issues 4 Pull Requests Activity

Tomsk Oblast, Sshivada, Negotiation & Bagnold's fluid.

This commit is contained in:
nik gaffney 2020-10-11 14:31:29 +02:00
parent e8c6f5800f
commit 8893482bfd
1 changed files with 61 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
group-scheduling.rkt
View File

@ -7,13 +7,19 @@
math)
;; echoing verbosity
(define verbose? (make-parameter #f))
(define verbose? #t)
(define (verbosity b)
(set! verbose? b)
(when verbose?
(printf "verbose output enabled~n")))
(define-syntax vecho
(syntax-rules ()
((_ str ...) (when (verbose?) (printf str ...)))))
((_ str ...) (when verbose? (printf str ...)))))
;; current version
(define version "2020-10-10 14:31:47")
(define version "2020-10-11 14:28:50")
(define (print-version)
(printf "version: ~a~n" version))
@ -84,8 +90,10 @@
(begin (meeting-2 p1 p2)
(cons (list p1 p2)
(make-new-2 (shuffle (remove* (list p1 p2) group)))))
'())))))
(begin
(vecho "couldn't create a meeting from group: ~a~n" group)
'()))))))
;; make some triples from a group
(define (make-new-3 group)
(cond
@ -96,15 +104,20 @@
(else
(let* ((p1 (car (shuffle group)))
(p2 (findf (lambda (x)
(not (have-they-met? p1 x))) (remove p1 group)))
(not (have-they-met? p1 x)))
(shuffle (remove p1 group))))
(p3 (findf (lambda (x)
(and (not (have-they-met? p1 x))
(not (have-they-met? p2 x)))) (remove* (list p1 p2) group))))
(not (have-they-met? p2 x))))
(shuffle (remove* (list p1 p2) group)))))
(vecho "testing: ~a, ~a & ~a~n" p1 p2 p3)
(if (and p1 p2 p3)
(begin (meeting-3 p1 p2 p3)
(cons (list p1 p2 p3)
(make-new-3 (shuffle (remove* (list p1 p2 p3) group)))))
'())))))
(begin
(vecho "couldn't create meeting from group: ~a~n" group)
'()))))))
;; make some quads from a group
(define (make-new-4 group)
@ -161,14 +174,14 @@
;; keep trying until something "complete" is output
;; determined by matching length as condition (TBC)
(define escape-counter 1001)
(define escape-counter 101)
(define (decrement-escape)
(printf ".")
(vecho ".")
(set! escape-counter (- escape-counter 1)))
(define (reset-escape)
(set! escape-counter 1001))
(set! escape-counter 101))
(define (ensure-new-5 group)
(decrement-escape)
@ -185,7 +198,6 @@
(set! %has-met t0)
(ensure-new-5 group)))))))
(define (ensure-new-4 group)
(decrement-escape)
(if (eq? 0 escape-counter)
@ -201,6 +213,36 @@
(set! %has-met t0)
(ensure-new-4 group)))))))
(define (ensure-new-3 group)
(decrement-escape)
(if (eq? 0 escape-counter)
(begin
(reset-escape)
(vecho "escaped from loopland...~n")
'())
(let ((t0 %has-met))
(let ((c (make-new-3 group)))
(if (eq? (length group) (length (flatten c)))
c
(begin
(set! %has-met t0)
(ensure-new-3 group)))))))
(define (ensure-new-2 group)
(decrement-escape)
(if (eq? 0 escape-counter)
(begin
(reset-escape)
(vecho "escaped from loopland...~n")
'())
(let ((t0 %has-met))
(let ((c (make-new-2 group)))
(if (eq? (length group) (length (flatten c)))
c
(begin
(set! %has-met t0)
(ensure-new-2 group)))))))
(define (check-group group)
(printf "group is ~s long. repeats? ~a~n~s~n"
(length (flatten group))
@ -359,7 +401,7 @@
(printf "pair: ~a & ~a~n"
(if g0 (first g0) "?")
(if (< 1 (length g0)) (second g0) "?")))
(make-new-2 group))
(ensure-new-2 group))
(printf "~n")))
(define (print-rounds-of-3 group n)
@ -370,7 +412,8 @@
(if g0 (first g0) "?")
(if (< 1 (length g0)) (second g0) "?")
(if (< 2 (length g0)) (third g0) "?")))
(make-new-3 group))
;;(make-new-3 group))
(ensure-new-3 group))
(printf "~n")))
(define (print-rounds-of-4 group n)
@ -383,7 +426,7 @@
(if (< 2 (length g0)) (third g0) "?")
(if (< 3 (length g0)) (fourth g0) "?")
))
(make-new-4 group))
(ensure-new-4 group))
(printf "~n")))
@ -392,9 +435,9 @@
(for-each (lambda (p0)
(printf "~a has met ~a others: ~a~n"
p0
(length (all-meetings p0))
(map (lambda (p1) (cdar p1))
(all-meetings p0))))
(- (length (all-meetings p0)) 2)
(drop (map (lambda (p1) (cdar p1))
(all-meetings p0)) 2)))
group)
(printf "~n"))