(module group-scheduling racket

  (provide (all-defined-out))
  
  (require racklog
           control
           math)

  ;; echoing verbosity
  (define verbose? #f)

  (define (verbosity b)
    (set! verbose? b)
      (when verbose?
          (printf "verbose output enabled~n")))
             
  (define-syntax vecho
    (syntax-rules ()
      ((_ str ...) (when verbose? (printf str ...)))))

  ;; current version
  (define version "2020-10-12 09:48:02")

  (define (print-version)
   (printf "version: ~a~n" version))
    
  ;;logics
  (define %has-met %empty-rel) ;; collection of meetings...
  (define %t0 %empty-rel)      ;; tentative collection...

  ;; meetings recordered via %assert should only be recorded once
  (use-occurs-check? #t)
  
  (define (meeting p1 p2)
    (vecho "meeting between: ~a & ~a~n" p1 p2)
    (unless (have-they-met? p1 p2)
      (begin 
        (%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-2 p1 p2)
    (meeting-2 p1 p3)
    (meeting-2 p2 p3))

  (define (meeting-4 p1 p2 p3 p4) ;; '((p1 p2 p3) (p1 p2 p4) (p1 p3 p4) (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-2 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) '())
     ((> 2 (length group))
      (begin
        (printf "leftover: 1~n") (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)))))
            (begin
              (vecho "couldn't create a meeting from group: ~a~n" group)
            '()))))))
            
  ;; make some triples from a group
  (define (make-new-3 group)
    (cond
     ((empty? group) '())
     ((> 3 (length group))
      (begin
        (printf "leftover: ~a~n" (length group)) (list group)))
     (else
      (let* ((p1 (car (shuffle group)))
             (p2 (findf (lambda (x)
                          (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))))
                        (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)
    (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 101)

  (define (decrement-escape)
    (vecho ".")
    (set! escape-counter (- escape-counter 1)))

  (define (reset-escape)
    (set! escape-counter 101))

  (define (ensure-new-5 group)
    (decrement-escape)
    (if (eq? 0 escape-counter)
	(begin
          (reset-escape)
          (vecho "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)
          (vecho "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 (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))
            (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)
    (vecho "trying: ~a and ~a from ~a\n" p1 p2 l)
    (if (empty? l) '()
	(if (have-they-met? (list p1 p2))
            (let ((p2q (car l)))
              (meeting-2 p1 p2q)
              (select-pairs-acc p1 p2q (remove p2 l)))
            (begin
              (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))))
					;(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)
    (vecho "trying: ~a, ~a and ~a from ~a\n" 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
		(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
          (vecho "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 impossible 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 (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))


  (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))
      (for-each (lambda (g0)
                  (printf "pair: ~a & ~a~n"
                          (if g0 (first g0) "?")
                          (if (< 1 (length g0)) (second g0) "?")))
                (ensure-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))
                (ensure-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) "?")
                          ))
                (ensure-new-4 group))
      (printf "~n")))


  (define (print-all-meetings group)
    (printf "Meetings so far:~n")
    (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)))
              group)
    (printf "~n"))

  )