From e8c6f5800fc2a8fb0ea88c45800286ee10ad5240 Mon Sep 17 00:00:00 2001 From: nik gaffney Date: Sat, 10 Oct 2020 14:38:15 +0200 Subject: [PATCH] Eastern alpine mannikin, Joint Astronomy Centre & 7th Baronet --- README.org | 7 +++- example-schedule.rkt | 30 +++++++-------- group-scheduling.rkt | 88 ++++++++++++++++++++++++++++---------------- 3 files changed, 77 insertions(+), 48 deletions(-) diff --git a/README.org b/README.org index d61b098..2db4e58 100644 --- a/README.org +++ b/README.org @@ -17,6 +17,11 @@ on debian/ubuntu sudo apt intall racket #+END_SRC +you might also need to install the ~control~ library +#+BEGIN_SRC shell +raco pkg install control +#+END_SRC + * schedule [[https://the-public-domain-review.imgix.net/collections/amundsen-s-south-pole-expedition/6504423149_f4ffeb13b8_o.jpg]] @@ -104,6 +109,6 @@ and test some other scenarios… * further -- [[https://www.geeksforgeeks.org/exact-cover-problem-algorithm-x-set-1/][Exact Cover Problem and Algorithm X]] +- [[https://arxiv.org/abs/cs/0011047][Dancing Links]], [[https://www.geeksforgeeks.org/exact-cover-problem-algorithm-x-set-1/][Exact Cover Problem and Algorithm X]] - [[https://en.wikipedia.org/wiki/Size_of_groups,_organizations,_and_communities][Size of groups, organizations, and communities]] - etc+ diff --git a/example-schedule.rkt b/example-schedule.rkt index 41be1ff..1fc6691 100644 --- a/example-schedule.rkt +++ b/example-schedule.rkt @@ -4,8 +4,8 @@ ;; define your group -(define fmba-group '("Fidelia" "Marcus" "Donnette" "Garrett" "Lida" "Reagan" "Myrta" "Ginny" "Juliann" "Maxwell" "Serena" "Chante" "Wen" "Malcom" "Lizbeth" "Aleida")) - +(define some-group '("Fidelia" "Marcus" "Donnette" "Garrett" "Lida" "Reagan" "Myrta" "Ginny" "Juliann" "Maxwell" "Serena" "Chante" "Wen" "Malcom" "Lizbeth" "Aleida")) + ;; the 'print-rounds' function determines if a particular arrangement of meetings ;; will nable everyon ein th egrouo to have met once. @@ -16,37 +16,37 @@ ;; show the scenario for week 1 -(print-test-rounds fmba-group 2 1 1) +(print-test-rounds some-group 2 1 1) ;; begin with seting up the meetings -(start-meetings fmba-group) +(start-meetings some-group) ;; make a few rounds... -(print-rounds-of-2 fmba-group 2) -(print-rounds-of-3 fmba-group 2) -(print-rounds-of-4 fmba-group 1) -(print-all-meetings fmba-group) +(print-rounds-of-2 some-group 2) +(print-rounds-of-3 some-group 2) +(print-rounds-of-4 some-group 1) +(print-all-meetings some-group) ;; and again... -(reset-meetings fmba-group) +(reset-meetings some-group) -(print-rounds-of-2 fmba-group 2) -(print-all-meetings fmba-group) +(print-rounds-of-2 some-group 2) +(print-all-meetings some-group) ;; ...and by end of week 2 (printf "\nweek 1 & week 2 (scenario 1)\n\n") -(print-test-rounds fmba-group 5 2 1) +(print-test-rounds some-group 5 2 1) (printf "\nweek 1 & week 2 (scenario 2)\n\n") -(print-test-rounds fmba-group 4 3 1) +(print-test-rounds some-group 4 3 1) (printf "\nweek 1 & week 2 (scenario 3)\n\n") -(print-test-rounds fmba-group 4 2 2) +(print-test-rounds some-group 4 2 2) (printf "\nweek 1 & week 2 (scenario 4)\n\n") -(print-test-rounds fmba-group 4 1 3) +(print-test-rounds some-group 4 1 3) diff --git a/group-scheduling.rkt b/group-scheduling.rkt index d24ea77..9437513 100644 --- a/group-scheduling.rkt +++ b/group-scheduling.rkt @@ -5,12 +5,25 @@ (require racklog control math) - + + ;; echoing verbosity + (define verbose? (make-parameter #f)) + (define-syntax vecho + (syntax-rules () + ((_ str ...) (when (verbose?) (printf str ...))))) + + ;; current version + (define version "2020-10-10 14:31:47") + + (define (print-version) + (printf "version: ~a~n" version)) + ;;logics (define %has-met %empty-rel) ;; collection of meetings... (define %t0 %empty-rel) ;; tentative collection... (define (meeting p1 p2) + (vecho "meeting between: ~a & ~a~n" p1 p2) (%assert! %has-met () ((p1 p2))) (%assert! %has-met () ((p2 p1)))) @@ -21,9 +34,9 @@ (meeting p1 p2)) (define (meeting-3 p1 p2 p3) - (meeting p1 p2) - (meeting p1 p3) - (meeting p2 p3)) + (meeting-2 p1 p2) + (meeting-2 p1 p3) + (meeting-2 p2 p3)) (define (meeting-4 p1 p2 p3 p4) (meeting-3 p1 p2 p3) @@ -41,7 +54,7 @@ ;; assume everyone has "met" themselves (define (start-meetings group) - (map (lambda (x) (meeting x x)) group) + (map (lambda (x) (meeting-2 x x)) group) (printf "starting with group: ~a~n~n" group)) (define (reset-meetings group) @@ -60,7 +73,9 @@ (define (make-new-2 group) (cond ((empty? group) '()) - ((> 4 (length group)) (list group)) + ((> 2 (length group)) + (begin + (printf "leftover: 1~n") (list group))) (else (let* ((p1 (car (shuffle group))) (p2 (findf (lambda (x) @@ -75,7 +90,9 @@ (define (make-new-3 group) (cond ((empty? group) '()) - ((> 4 (length group)) (list group)) + ((> 3 (length group)) + (begin + (printf "leftover: ~a~n" (length group)) (list group))) (else (let* ((p1 (car (shuffle group))) (p2 (findf (lambda (x) @@ -144,20 +161,21 @@ ;; keep trying until something "complete" is output ;; determined by matching length as condition (TBC) - (define escape-counter 100) + (define escape-counter 1001) (define (decrement-escape) + (printf ".") (set! escape-counter (- escape-counter 1))) (define (reset-escape) - (set! escape-counter 100)) + (set! escape-counter 1001)) (define (ensure-new-5 group) (decrement-escape) (if (eq? 0 escape-counter) (begin (reset-escape) - (printf "escaped from loopland...~n") + (vecho "escaped from loopland...~n") '()) (let ((t0 %has-met)) (let ((c (make-new-5 group))) @@ -173,7 +191,7 @@ (if (eq? 0 escape-counter) (begin (reset-escape) - (printf "escaped from loopland...~n") + (vecho "escaped from loopland...~n") '()) (let ((t0 %has-met)) (let ((c (make-new-4 group))) @@ -224,18 +242,20 @@ (else (cons (list (first l) (second l) (third l) (fourth l)) (group-fours (list-tail l 4))))))) -;;; pairs - + ;;; pairs (define (select-pairs-acc p1 p2 l) + (vecho "trying: ~a and ~a from ~a\n" p1 p2 l) (if (empty? l) '() (if (have-they-met? (list p1 p2)) - (select-pairs-acc p1 (car l) (remove p2 l)) + (let ((p2q (car l))) + (meeting-2 p1 p2q) + (select-pairs-acc p1 p2q (remove p2 l))) (begin - ;(printf "adding: ~a and ~a from ~a\n" p1 p2 l) (meeting-2 p1 p2) (cons (list p1 p2) (select-pairs (remove* (list p1 p2) l))))))) (define (select-pairs l) + (vecho "selecting pairs...~n") (if (< (length l) 1) '() (let ((p1 (car l)) (p2 (car (shuffle l)))) @@ -243,9 +263,9 @@ (select-pairs-acc p1 p2 l)))) -;;; triples - + ;;; triples (define (select-3fold-acc p1 p2 p3 l) + (vecho "trying: ~a, ~a and ~a from ~a\n" p1 p2 p3 l) (if (empty? l) '() (cond ((have-they-met? (list p1 p2)) @@ -255,21 +275,21 @@ ((have-they-met? (list p2 p3)) (select-3fold-acc p1 p2 (car l) (remove p3 l))) (else (begin - ;(printf "adding: ~a, ~a and ~a from ~a\n" p1 p2 p3 l) + (vecho "adding: ~a, ~a and ~a from ~a\n" p1 p2 p3 l) (meeting-3 p1 p2 p3) (cons (list p1 p2 p3) (select-3fold (remove* (list p1 p2 p3) l)))))))) - (define (select-3fold l) + (vecho "selecting 3fold...~n") (if (< (length l) 1) '() (let ((p1 (car l)) (p2 (car (shuffle l))) ;; maybe duplicate (p3 (car (shuffle l)))) ;; maybe duplicate - ;(printf "possibly: ~a and ~a from ~a\n" p1 p2 l) + (vecho "possibly: ~a and ~a from ~a\n" p1 p2 l) (select-3fold-acc p1 p2 p3 l)))) -;;; fours - + + ;;; fours (define (select-4fold-acc p1 p2 p3 p4 l) (if (empty? l) '() (cond @@ -283,7 +303,6 @@ ;(printf "adding: ~a, ~a and ~a from ~a\n" p1 p2 p3 l) (meeting-4 p1 p2 p3 p4) (cons (list p1 p2 p3 p4) (select-3fold (remove* (list p1 p2 p3) l)))))))) - (define (select-4fold l) (if (< (length l) 1) '() @@ -313,9 +332,12 @@ (define (print-test-rounds l n1 n2 n3) (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 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 2, there can be ~s distinct groupings\n" + n1 (floor (* n1 (/ (length l) 2)))) + (printf "in ~a rounds of 3, there can be ~s distinct groupings\n" + n2 (floor (* n2 (/ (length l) 3)))) + (printf "in ~a rounds of 4, there can be ~s distinct groupings\n" + n3 (floor (* n3 (/ (length l) 4)))) (cross-chatter (length l) n1 n2 n3)) @@ -333,9 +355,11 @@ (define (print-rounds-of-2 group n) (dotimes (x n) (printf "next round [2:~a]~n" (+ x 1)) - (map (lambda (pair) - (printf "pair: ~a & ~a~n" (first pair) (second pair))) - (make-new-2 group)) + (for-each (lambda (g0) + (printf "pair: ~a & ~a~n" + (if g0 (first g0) "?") + (if (< 1 (length g0)) (second g0) "?"))) + (make-new-2 group)) (printf "~n"))) (define (print-rounds-of-3 group n) @@ -368,9 +392,9 @@ (for-each (lambda (p0) (printf "~a has met ~a others: ~a~n" p0 - (- (length (all-meetings p0)) 2) - (drop (map (lambda (p1) (cdar p1)) - (all-meetings p0)) 2))) + (length (all-meetings p0)) + (map (lambda (p1) (cdar p1)) + (all-meetings p0)))) group) (printf "~n"))