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

Pundori Kalan, 256-bit computing, Landmann & Eureka Sound

Browse source
This commit is contained in:
nik gaffney 2020-10-05 11:07:51 +02:00
parent 1ca02681e5
commit eca6832f5d
1 changed files with 264 additions and 265 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

521
group-scheduling.rkt
View file

@ -1,69 +1,67 @@
#lang racket
(module group-scheduling racket (module group-scheduling racket
(provide (all-defined-out)) (provide (all-defined-out))
(require racklog (require racklog
control control
math) math)
;;logics ;;logics
(define %has-met %empty-rel) ;; collection of meetings... (define %has-met %empty-rel) ;; collection of meetings...
(define %t0 %empty-rel) ;; tentative collection... (define %t0 %empty-rel) ;; tentative collection...
(define (meeting p1 p2) (define (meeting p1 p2)
(%assert! %has-met () ((p1 p2))) (%assert! %has-met () ((p1 p2)))
(%assert! %has-met () ((p2 p1)))) (%assert! %has-met () ((p2 p1))))
;; various meetings... ;; various meetings...
;; e.g. (combinations '(p1 p2 p3 p4 p5) 4) ;; e.g. (combinations '(p1 p2 p3 p4 p5) 4)
(define (meeting-2 p1 p2) (define (meeting-2 p1 p2)
(meeting p1 p2)) (meeting p1 p2))
(define (meeting-3 p1 p2 p3) (define (meeting-3 p1 p2 p3)
(meeting p1 p2) (meeting p1 p2)
(meeting p1 p3) (meeting p1 p3)
(meeting p2 p3)) (meeting p2 p3))
(define (meeting-4 p1 p2 p3 p4) (define (meeting-4 p1 p2 p3 p4)
(meeting-3 p1 p2 p3) (meeting-3 p1 p2 p3)
(meeting-3 p1 p2 p4) (meeting-3 p1 p2 p4)
(meeting-3 p1 p3 p4) (meeting-3 p1 p3 p4)
(meeting-3 p2 p3 p4)) (meeting-3 p2 p3 p4))
(define (meeting-5 p1 p2 p3 p4 p5) (define (meeting-5 p1 p2 p3 p4 p5)
(meeting-4 p1 p2 p3 p4) (meeting-4 p1 p2 p3 p4)
(meeting-4 p1 p2 p3 p5) (meeting-4 p1 p2 p3 p5)
(meeting-4 p1 p2 p4 p5) (meeting-4 p1 p2 p4 p5)
(meeting-4 p1 p3 p4 p5) (meeting-4 p1 p3 p4 p5)
(meeting-4 p2 p3 p4 p5)) (meeting-4 p2 p3 p4 p5))
;; assume everyone has "met" themselves ;; assume everyone has "met" themselves
(define (start-meetings group) (define (start-meetings group)
(map (lambda (x) (meeting x x)) group) (map (lambda (x) (meeting x x)) group)
(printf "starting with group: ~a~n~n" group)) (printf "starting with group: ~a~n~n" group))
(define (reset-meetings group) (define (reset-meetings group)
(printf "resetting.~n") (printf "resetting.~n")
(set! %has-met %empty-rel) (set! %has-met %empty-rel)
(start-meetings group)) (start-meetings group))
(define (have-they-met? x y) (define (have-they-met? x y)
(if (%which () (%has-met x y)) #t #f)) (if (%which () (%has-met x y)) #t #f))
(define (all-meetings x) (define (all-meetings x)
(%find-all (who) (%has-met x who))) (%find-all (who) (%has-met x who)))
;; make some pairs from a group ;; make some pairs from a group
(define (make-new-2 group) (define (make-new-2 group)
(cond (cond
((empty? group) '()) ((empty? group) '())
((> 4 (length group)) (list group)) ((> 4 (length group)) (list group))
(else (else
(let* ((p1 (car (shuffle group))) (let* ((p1 (car (shuffle group)))
(p2 (findf (lambda (x) (p2 (findf (lambda (x)
(not (have-they-met? p1 x))) (remove p1 group)))) (not (have-they-met? p1 x))) (remove p1 group))))
@ -73,36 +71,36 @@
(make-new-2 (shuffle (remove* (list p1 p2) group))))) (make-new-2 (shuffle (remove* (list p1 p2) group)))))
'()))))) '())))))
;; make some triples from a group ;; make some triples from a group
(define (make-new-3 group) (define (make-new-3 group)
(cond (cond
((empty? group) '()) ((empty? group) '())
((> 4 (length group)) (list group)) ((> 4 (length group)) (list group))
(else (else
(let* ((p1 (car (shuffle group))) (let* ((p1 (car (shuffle group)))
(p2 (findf (lambda (x) (p2 (findf (lambda (x)
(not (have-they-met? p1 x))) (remove p1 group))) (not (have-they-met? p1 x))) (remove p1 group)))
(p3 (findf (lambda (x) (p3 (findf (lambda (x)
(and (not (have-they-met? p1 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)))) (remove* (list p1 p2) group))))
(if (and p1 p2 p3) (if (and p1 p2 p3)
(begin (meeting-3 p1 p2 p3) (begin (meeting-3 p1 p2 p3)
(cons (list p1 p2 p3) (cons (list p1 p2 p3)
(make-new-3 (shuffle (remove* (list p1 p2 p3) group))))) (make-new-3 (shuffle (remove* (list p1 p2 p3) group)))))
'()))))) '())))))
;; make some quads from a group ;; make some quads from a group
(define (make-new-4 group) (define (make-new-4 group)
(cond (cond
((empty? group) '()) ((empty? group) '())
((> 4 (length group)) (list group)) ((> 4 (length group)) (list group))
(else (else
(let* ((p1 (car (shuffle group))) (let* ((p1 (car (shuffle group)))
(p2 (findf (lambda (x) (p2 (findf (lambda (x)
(not (have-they-met? p1 x))) (remove p1 group))) (not (have-they-met? p1 x))) (remove p1 group)))
(p3 (findf (lambda (x) (p3 (findf (lambda (x)
(and (not (have-they-met? p1 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)))) (remove* (list p1 p2) group)))
(p4 (findf (lambda (x) (p4 (findf (lambda (x)
(and (not (have-they-met? p1 x)) (and (not (have-they-met? p1 x))
(not (have-they-met? p2 x)) (not (have-they-met? p2 x))
@ -114,18 +112,18 @@
'()))))) '())))))
;; make some fivefiold from a group ;; make some fivefiold from a group
(define (make-new-5 group) (define (make-new-5 group)
(cond (cond
((empty? group) '()) ((empty? group) '())
((> 5 (length group)) (list group)) ((> 5 (length group)) (list group))
(else (else
(let* ((p1 (car (shuffle group))) (let* ((p1 (car (shuffle group)))
(p2 (findf (lambda (x) (p2 (findf (lambda (x)
(not (have-they-met? p1 x))) (remove p1 group))) (not (have-they-met? p1 x))) (remove p1 group)))
(p3 (findf (lambda (x) (p3 (findf (lambda (x)
(and (not (have-they-met? p1 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)))) (remove* (list p1 p2) group)))
(p4 (findf (lambda (x) (p4 (findf (lambda (x)
(and (not (have-they-met? p1 x)) (and (not (have-they-met? p1 x))
(not (have-they-met? p2 x)) (not (have-they-met? p2 x))
@ -142,236 +140,237 @@
'()))))) '())))))
;; brute repetitor ;; brute repetitor
;; keep trying until something "complete" is output ;; keep trying until something "complete" is output
;; determined by matching length as condition (TBC) ;; determined by matching length as condition (TBC)
(define escape-counter 100) (define escape-counter 100)
(define (decrement-escape) (define (decrement-escape)
(set! escape-counter (- escape-counter 1))) (set! escape-counter (- escape-counter 1)))
(define (reset-escape) (define (reset-escape)
(set! escape-counter 100)) (set! escape-counter 100))
(define (ensure-new-5 group) (define (ensure-new-5 group)
(decrement-escape) (decrement-escape)
(if (eq? 0 escape-counter) (if (eq? 0 escape-counter)
(begin (begin
(reset-escape) (reset-escape)
(printf "escaped from loopland...~n") (printf "escaped from loopland...~n")
'()) '())
(let ((t0 %has-met)) (let ((t0 %has-met))
(let ((c (make-new-5 group))) (let ((c (make-new-5 group)))
(if (eq? (length group) (length (flatten c))) (if (eq? (length group) (length (flatten c)))
c c
(begin (begin
(set! %has-met t0) (set! %has-met t0)
(ensure-new-5 group))))))) (ensure-new-5 group)))))))
(define (ensure-new-4 group) (define (ensure-new-4 group)
(decrement-escape) (decrement-escape)
(if (eq? 0 escape-counter) (if (eq? 0 escape-counter)
(begin (begin
(reset-escape) (reset-escape)
(printf "escaped from loopland...~n") (printf "escaped from loopland...~n")
'()) '())
(let ((t0 %has-met)) (let ((t0 %has-met))
(let ((c (make-new-4 group))) (let ((c (make-new-4 group)))
(if (eq? (length group) (length (flatten c))) (if (eq? (length group) (length (flatten c)))
c c
(begin (begin
(set! %has-met t0) (set! %has-met t0)
(ensure-new-4 group))))))) (ensure-new-4 group)))))))
(define (check-group group) (define (check-group group)
(printf "group is ~s long. repeats? ~a~n~s~n" (printf "group is ~s long. repeats? ~a~n~s~n"
(length (flatten group)) (length (flatten group))
(check-duplicates (flatten group)) (check-duplicates (flatten group))
(sort (flatten group) string<?))) (sort (flatten group) string<?)))
;; etc etc+ ;; etc etc+
(define (group-pairs l0) (define (group-pairs l0)
(let ((l (shuffle l0))) (let ((l (shuffle l0)))
(when (> (remainder (length l) 2) 0) (when (> (remainder (length l) 2) 0)
(printf "there will be ~a leftover.\n" (remainder (length l) 2))) (printf "there will be ~a leftover.\n" (remainder (length l) 2)))
(if (empty? l) '() (if (empty? l) '()
(if (= 1 (length l)) (cons l '()) (if (= 1 (length l)) (cons l '())
(cons (list (first l) (second l)) (group-pairs (list-tail l 2))))))) (cons (list (first l) (second l)) (group-pairs (list-tail l 2)))))))
(define (group-threes l0) (define (group-threes l0)
(let ((l (shuffle l0))) (let ((l (shuffle l0)))
(when (> (remainder (length l) 3) 0) (when (> (remainder (length l) 3) 0)
(printf "there will be ~a leftover.\n" (remainder (length l) 3))) (printf "there will be ~a leftover.\n" (remainder (length l) 3)))
(case (length l) (case (length l)
((0) '()) ((0) '())
((1) (cons l '())) ((1) (cons l '()))
((2) (cons (list (first l) (second l)) '())) ((2) (cons (list (first l) (second l)) '()))
(else (cons (list (first l) (second l) (third l)) (else (cons (list (first l) (second l) (third l))
(group-threes (list-tail l 3))))))) (group-threes (list-tail l 3)))))))
(define (group-fours l0) (define (group-fours l0)
(let ((l (shuffle l0))) (let ((l (shuffle l0)))
(when (> (remainder (length l) 4) 0) (when (> (remainder (length l) 4) 0)
(printf "there will be ~a leftover.\n" (remainder (length l) 4))) (printf "there will be ~a leftover.\n" (remainder (length l) 4)))
(case (length l) (case (length l)
((0) '()) ((0) '())
((1) (cons l '())) ((1) (cons l '()))
((2) (cons (list (first l) (second l)) '())) ((2) (cons (list (first l) (second l)) '()))
((3) (cons (list (first l) (second l) (third l)) '())) ((3) (cons (list (first l) (second l) (third l)) '()))
(else (cons (list (first l) (second l) (third l) (fourth l)) (else (cons (list (first l) (second l) (third l) (fourth l))
(group-fours (list-tail l 4))))))) (group-fours (list-tail l 4)))))))
;;; pairs ;;; pairs
(define (select-pairs-acc p1 p2 l) (define (select-pairs-acc p1 p2 l)
(if (empty? l) '() (if (empty? l) '()
(if (have-they-met? (list p1 p2)) (if (have-they-met? (list p1 p2))
(select-pairs-acc p1 (car l) (remove p2 l)) (select-pairs-acc p1 (car l) (remove p2 l))
(begin (begin
;(printf "adding: ~a and ~a from ~a\n" p1 p2 l) ;(printf "adding: ~a and ~a from ~a\n" p1 p2 l)
(meeting-2 p1 p2) (meeting-2 p1 p2)
(cons (list p1 p2) (select-pairs (remove* (list p1 p2) l))))))) (cons (list p1 p2) (select-pairs (remove* (list p1 p2) l)))))))
(define (select-pairs l) (define (select-pairs l)
(if (< (length l) 1) '() (if (< (length l) 1) '()
(let ((p1 (car l)) (let ((p1 (car l))
(p2 (car (shuffle l)))) (p2 (car (shuffle l))))
;(printf "possibly: ~a and ~a from ~a\n" p1 p2 l) ;(printf "possibly: ~a and ~a from ~a\n" p1 p2 l)
(select-pairs-acc p1 p2 l)))) (select-pairs-acc p1 p2 l))))
;;; triples ;;; triples
(define (select-3fold-acc p1 p2 p3 l) (define (select-3fold-acc p1 p2 p3 l)
(if (empty? l) '() (if (empty? l) '()
(cond (cond
((have-they-met? (list p1 p2)) ((have-they-met? (list p1 p2))
(select-3fold-acc p1 (car l) p3 (remove p2 l))) (select-3fold-acc p1 (car l) p3 (remove p2 l)))
((have-they-met? (list p1 p3)) ((have-they-met? (list p1 p3))
(select-3fold-acc p1 p2 (car l) (remove p3 l))) (select-3fold-acc p1 p2 (car l) (remove p3 l)))
((have-they-met? (list p2 p3)) ((have-they-met? (list p2 p3))
(select-3fold-acc p1 p2 (car l) (remove p3 l))) (select-3fold-acc p1 p2 (car l) (remove p3 l)))
(else (begin (else (begin
;(printf "adding: ~a, ~a and ~a from ~a\n" p1 p2 p3 l) ;(printf "adding: ~a, ~a and ~a from ~a\n" p1 p2 p3 l)
(meeting-3 p1 p2 p3) (meeting-3 p1 p2 p3)
(cons (list p1 p2 p3) (select-3fold (remove* (list p1 p2 p3) l)))))))) (cons (list p1 p2 p3) (select-3fold (remove* (list p1 p2 p3) l))))))))
(define (select-3fold l) (define (select-3fold l)
(if (< (length l) 1) '() (if (< (length l) 1) '()
(let ((p1 (car l)) (let ((p1 (car l))
(p2 (car (shuffle l))) ;; maybe duplicate (p2 (car (shuffle l))) ;; maybe duplicate
(p3 (car (shuffle l)))) ;; maybe duplicate (p3 (car (shuffle l)))) ;; maybe duplicate
;(printf "possibly: ~a and ~a from ~a\n" p1 p2 l) ;(printf "possibly: ~a and ~a from ~a\n" p1 p2 l)
(select-3fold-acc p1 p2 p3 l)))) (select-3fold-acc p1 p2 p3 l))))
;;; fours ;;; fours
(define (select-4fold-acc p1 p2 p3 p4 l) (define (select-4fold-acc p1 p2 p3 p4 l)
(if (empty? l) '() (if (empty? l) '()
(cond (cond
((have-they-met? (list p1 p2 p3 p4)) ((have-they-met? (list p1 p2 p3 p4))
(select-4fold-acc p1 (car l) p2 p3 (remove p2 l))) (select-4fold-acc p1 (car l) p2 p3 (remove p2 l)))
((have-they-met? (list p1 p3)) ((have-they-met? (list p1 p3))
(select-4fold-acc p1 p2 (car l) (remove p3 l))) (select-4fold-acc p1 p2 (car l) (remove p3 l)))
((have-they-met? (list p2 p3)) ((have-they-met? (list p2 p3))
(select-4fold-acc p1 p2 (car l) (remove p3 l))) (select-4fold-acc p1 p2 (car l) (remove p3 l)))
(else (begin (else (begin
;(printf "adding: ~a, ~a and ~a from ~a\n" p1 p2 p3 l) ;(printf "adding: ~a, ~a and ~a from ~a\n" p1 p2 p3 l)
(meeting-4 p1 p2 p3 p4) (meeting-4 p1 p2 p3 p4)
(cons (list p1 p2 p3 p4) (select-3fold (remove* (list p1 p2 p3) l)))))))) (cons (list p1 p2 p3 p4) (select-3fold (remove* (list p1 p2 p3) l))))))))
(define (select-4fold l) (define (select-4fold l)
(if (< (length l) 1) '() (if (< (length l) 1) '()
(let ((p1 (car l)) (let ((p1 (car l))
(p2 (car (shuffle l))) ;; maybe duplicate (p2 (car (shuffle l))) ;; maybe duplicate
(p3 (car (shuffle l))) ;; maybe duplicate (p3 (car (shuffle l))) ;; maybe duplicate
(p4 (car (shuffle l)))) ;; maybe duplicate (p4 (car (shuffle l)))) ;; maybe duplicate
;(printf "possibly: ~a and ~a from ~a\n" p1 p2 l) ;(printf "possibly: ~a and ~a from ~a\n" p1 p2 l)
(select-4fold-acc p1 p2 p3 p4 l)))) (select-4fold-acc p1 p2 p3 p4 l))))
;; printing and/or output ;; printing and/or output
(define (print-combinations g n) (define (print-combinations g n)
(printf "There are ~a combinations of ~a. \n~a\n\n" (printf "There are ~a combinations of ~a. \n~a\n\n"
(binomial (length g) n) (binomial (length g) n)
n n
(when (>= 120 (binomial (length g) n)) (when (>= 120 (binomial (length g) n))
(combinations g n)))) (combinations g n))))
(define (cross-chatter n r1 r2 r3) ;; n = group size, r = num of rounds (at n=2,3,4) (define (cross-chatter n r1 r2 r3) ;; n = group size, r = num of rounds (at n=2,3,4)
(let ((m0 (- n 1))) (let ((m0 (- n 1)))
(printf "Each person needs to meet ~a other people, " m0) (printf "Each person needs to meet ~a other people, " m0)
(if (<= m0 (+ r1 (* r2 2) (* r3 3))) (if (<= m0 (+ r1 (* r2 2) (* r3 3)))
(printf "which is possible.~n~n") (printf "which is possible.~n~n")
(printf "which is impossible with this arrangement.~n~n")))) (printf "which is impossible with this arrangement.~n~n"))))
(define (print-test-rounds l n1 n2 n3) (define (print-test-rounds l n1 n2 n3)
(printf "There are ~a people (binomial ~a)\n" (length l) (binomial (length l) 2)) (printf "There are ~a people (binomial ~a)\n" (length l) (binomial (length l) 2))
(printf "in ~a rounds of 2, there can be ~s distinct groupings\n" n1 (* n1 (/ (length l) 2))) (printf "in ~a rounds of 2, there can be ~s distinct groupings\n" n1 (* n1 (/ (length l) 2)))
(printf "in ~a rounds of 3, there can be ~s distinct groupings\n" n2 (* n2 (/ (length l) 3))) (printf "in ~a rounds of 3, there can be ~s distinct groupings\n" n2 (* n2 (/ (length l) 3)))
(printf "in ~a rounds of 4, there can be ~s distinct groupings\n" n3 (* n3 (/ (length l) 4))) (printf "in ~a rounds of 4, there can be ~s distinct groupings\n" n3 (* n3 (/ (length l) 4)))
(cross-chatter (length l) n1 n2 n3)) (cross-chatter (length l) n1 n2 n3))
(define (print-pairs l) (define (print-pairs l)
(printf "\nnext round, in pairs.\n") (printf "\nnext round, in pairs.\n")
(for ((p0 (select-pairs l))) (for ((p0 (select-pairs l)))
(printf "meeting: ~a and ~a\n" (car p0) (second p0)))) (printf "meeting: ~a and ~a\n" (car p0) (second p0))))
(define (print-3fold l) (define (print-3fold l)
(printf "\nnext round, groups of 3.\n") (printf "\nnext round, groups of 3.\n")
(for ((p0 (select-3fold l))) (for ((p0 (select-3fold l)))
(printf "meeting: ~a, ~a and ~a\n" (car p0) (second p0) (third p0)))) (printf "meeting: ~a, ~a and ~a\n" (car p0) (second p0) (third p0))))
;; print and/or ceate subgroups ;; print and/or ceate subgroups
(define (print-rounds-of-2 group n) (define (print-rounds-of-2 group n)
(dotimes (x n) (dotimes (x n)
(printf "next round [2:~a]~n" (+ x 1)) (printf "next round [2:~a]~n" (+ x 1))
(map (lambda (pair) (map (lambda (pair)
(printf "pair: ~a & ~a~n" (first pair) (second pair))) (printf "pair: ~a & ~a~n" (first pair) (second pair)))
(make-new-2 group)) (make-new-2 group))
(printf "~n"))) (printf "~n")))
(define (print-rounds-of-3 group n) (define (print-rounds-of-3 group n)
(dotimes (x n) (dotimes (x n)
(printf "next round [3:~a]~n" (+ x 1)) (printf "next round [3:~a]~n" (+ x 1))
(for-each (lambda (g0) (for-each (lambda (g0)
(printf "3fold: ~a, ~a & ~a~n" (printf "3fold: ~a, ~a & ~a~n"
(if g0 (first g0) "?") (if g0 (first g0) "?")
(if (< 1 (length g0)) (second g0) "?") (if (< 1 (length g0)) (second g0) "?")
(if (< 2 (length g0)) (third g0) "?"))) (if (< 2 (length g0)) (third g0) "?")))
(make-new-3 group)) (make-new-3 group))
(printf "~n"))) (printf "~n")))
(define (print-rounds-of-4 group n) (define (print-rounds-of-4 group n)
(dotimes (x n) (dotimes (x n)
(printf "next round [4:~a]~n" (+ x 1)) (printf "next round [4:~a]~n" (+ x 1))
(for-each (lambda (g0) (for-each (lambda (g0)
(printf "4fold: ~a, ~a, ~a & ~a~n" (printf "4fold: ~a, ~a, ~a & ~a~n"
(if g0 (first g0) "?") (if g0 (first g0) "?")
(if (< 1 (length g0)) (second g0) "?") (if (< 1 (length g0)) (second g0) "?")
(if (< 2 (length g0)) (third g0) "?") (if (< 2 (length g0)) (third g0) "?")
(if (< 3 (length g0)) (fourth g0) "?") (if (< 3 (length g0)) (fourth g0) "?")
)) ))
(make-new-4 group)) (make-new-4 group))
(printf "~n"))) (printf "~n")))
(define (print-all-meetings group) (define (print-all-meetings group)
(printf "Meetings so far:~n") (printf "Meetings so far:~n")
(for-each (lambda (p0) (for-each (lambda (p0)
(printf "~a has met ~a~n" (printf "~a has met ~a~n"
p0 (drop (map (lambda (p1) (cdar p1)) p0 (drop (map (lambda (p1) (cdar p1))
(all-meetings p0)) 2))) (all-meetings p0)) 2)))
group) group)
(printf "~n")) (printf "~n"))
)
)