From 8893482bfd87f81d866d92a3f1e7bcd31d1d3fad Mon Sep 17 00:00:00 2001
From: nik gaffney <nik@fo.am>
Date: Sun, 11 Oct 2020 14:31:29 +0200
Subject: [PATCH] Tomsk Oblast, Sshivada, Negotiation & Bagnold's fluid.

---
 group-scheduling.rkt | 79 ++++++++++++++++++++++++++++++++++----------
 1 file changed, 61 insertions(+), 18 deletions(-)

diff --git a/group-scheduling.rkt b/group-scheduling.rkt
index 9437513..d47eb52 100644
--- a/group-scheduling.rkt
+++ b/group-scheduling.rkt
@@ -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"))