Eastern alpine mannikin, Joint Astronomy Centre & 7th Baronet

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+

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-2 some-group 2)
-(print-rounds-of-3 fmba-group 2)
+(print-rounds-of-3 some-group 2)
-(print-rounds-of-4 fmba-group 1)
+(print-rounds-of-4 some-group 1)
-(print-all-meetings fmba-group)
+(print-all-meetings some-group)
 
 ;; and again...
-(reset-meetings fmba-group)
+(reset-meetings some-group)
 
-(print-rounds-of-2 fmba-group 2)
+(print-rounds-of-2 some-group 2)
-(print-all-meetings fmba-group)
+(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)
 
 
 

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-2 p1 p2)
-    (meeting p1 p3)
+    (meeting-2 p1 p3)
-    (meeting p2 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 2, there can be ~s distinct groupings\n"
-    (printf "in ~a rounds of 3, there can be ~s distinct groupings\n" n2 (* n2 (/ (length l) 3)))
+            n1 (floor (* n1 (/ (length l) 2))))
-    (printf "in ~a rounds of 4, there can be ~s distinct groupings\n" n3 (* n3 (/ (length l) 4)))
+    (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)
+      (for-each (lambda (g0)
-             (printf "pair: ~a & ~a~n" (first pair) (second pair)))
+                  (printf "pair: ~a & ~a~n"
-           (make-new-2 group))
+                          (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)
+                        (length (all-meetings p0))
-                        (drop (map (lambda (p1) (cdar p1))
+                        (map (lambda (p1) (cdar p1))
-                                      (all-meetings p0)) 2)))
+                                      (all-meetings p0))))
               group)
     (printf "~n"))