Khugaung, Mangifera campnospermoides, Amanita armeniaca & Beamter.

README.org

@@ -0,0 +1,97 @@
+# -*- mode: org;  coding: utf-8; -*-
+#+title: scheduling and grouping
+
+A way to find various subgroups of a group… 
+
+* install 
+
+To run this programme you’ll need a working version of [[https://racket-lang.org/][Racket]] installed. An installer can be downloaded from https://download.racket-lang.org/
+
+* schedule
+
+setup…
+#+BEGIN_SRC racket
+(require "group-scheduling.rkt")
+#+END_SRC
+
+define your group as a list of names (or similar)…
+
+#+BEGIN_SRC racket
+(define fmba-group '("Fidelia" "Marcus" "Donnette" "Garrett" "Lida" "Reagan" "Myrta" "Ginny" "Juliann" "Maxwell" "Serena" "Chante" "Wen" "Malcom" "Lizbeth" "Aleida"))
+#+END_SRC
+
+the =print-test-rounds= function determines if a particular arrangement of meetings  will enable everyone in the group to  meet once….
+
+it's given a group (i.e. a list of names) and the number of rounds of 2, 3 or 4 people
+ - first. number of rounds of pairs
+ - second. number of rounds of 3 person groups
+ - third.  number of rounds of 4 person groups
+
+So 2 rounds of pairs, one round of groups of 3 and one round of groups of 4 would look like this…
+#+BEGIN_SRC racket
+(print-test-rounds fmba-group 2 1 1)
+#+END_SRC
+
+begin with setting up the meetings
+#+BEGIN_SRC racket
+(start-meetings fmba-group)
+#+END_SRC
+
+make a few rounds…
+#+BEGIN_SRC racket
+(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)
+#+END_SRC
+
+reset the meetings (i.e. forget who has net who) and go again…
+#+BEGIN_SRC racket
+(reset-meetings fmba-group)
+#+END_SRC
+
+#+BEGIN_SRC racket
+(print-rounds-of-2 fmba-group 2)
+#+END_SRC
+
+show who has met in the meetings that have happened…
+#+BEGIN_SRC racket
+(print-all-meetings fmba-group)
+#+END_SRC
+
+try a few scenarios…
+
+Week 1: 3x rounds of 2, 1x round of 3
+Week 2: 2x rounds of 2, 1x round of 3, 1x round of 4
+Week 3: 2x rounds of 2, 1x round of 3, 1x round of 4
+Week 4: 2x rounds of 2, 2x rounds of 4
+
+which looks like…
+#+BEGIN_SRC racket
+(print-test-rounds fmba-group 3 1 0)
+(print-test-rounds fmba-group 2 1 1)
+(print-test-rounds fmba-group 2 1 1)
+(print-test-rounds fmba-group 2 0 2)
+#+END_SRC
+
+and test some other scenarios…
+
+#+BEGIN_SRC racket
+(printf "\nweek 1 & week 2 (scenario 1)\n\n")
+(print-test-rounds fmba-group 5 2 1)
+
+(printf "\nweek 1 & week 2 (scenario 2)\n\n")
+(print-test-rounds fmba-group 4 3 1)
+
+(printf "\nweek 1 & week 2 (scenario 3)\n\n")
+(print-test-rounds fmba-group 4 2 2)
+
+(printf "\nweek 1 & week 2  (scenario 4)\n\n")
+(print-test-rounds fmba-group 4 1 3)
+#+END_SRC
+
+* further
+
+- [[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+

fmba-schedule.rkt

@@ -0,0 +1,56 @@
+#lang racket
+
+(require "group-scheduling.rkt")
+
+;; define your group
+
+(define fmba-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.
+
+;; it's given a group (i.e. a list of names) and the number of rounds of 2, 3 or 4 
+;; first. number of rounds of pairs
+;; second. number of rounds of 3 person groups
+;; third.  number of rounds of 4 person groups
+
+
+;; show the scenario for week 1
+(print-test-rounds fmba-group 2 1 1)
+
+
+;; begin with seting up the meetings
+(start-meetings fmba-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)
+
+;; and again...
+(reset-meetings fmba-group)
+
+(print-rounds-of-2 fmba-group 2)
+(print-all-meetings fmba-group)
+
+
+;; ...and by end of week 2
+(printf "\nweek 1 & week 2 (scenario 1)\n\n")
+(print-test-rounds fmba-group 5 2 1)
+
+(printf "\nweek 1 & week 2 (scenario 2)\n\n")
+(print-test-rounds fmba-group 4 3 1)
+
+(printf "\nweek 1 & week 2 (scenario 3)\n\n")
+(print-test-rounds fmba-group 4 2 2)
+
+(printf "\nweek 1 & week 2  (scenario 4)\n\n")
+(print-test-rounds fmba-group 4 1 3)
+
+
+
+
+
+
+

group-scheduling.rkt

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