Eastern alpine mannikin, Joint Astronomy Centre & 7th Baronet

This commit is contained in:
nik gaffney 2020-10-10 14:38:15 +02:00
parent cadbd7f114
commit e8c6f5800f
3 changed files with 77 additions and 48 deletions

View file

@ -17,6 +17,11 @@ on debian/ubuntu
sudo apt intall racket sudo apt intall racket
#+END_SRC #+END_SRC
you might also need to install the ~control~ library
#+BEGIN_SRC shell
raco pkg install control
#+END_SRC
* schedule * schedule
[[https://the-public-domain-review.imgix.net/collections/amundsen-s-south-pole-expedition/6504423149_f4ffeb13b8_o.jpg]] [[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 * 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]] - [[https://en.wikipedia.org/wiki/Size_of_groups,_organizations,_and_communities][Size of groups, organizations, and communities]]
- etc+ - etc+

View file

@ -4,8 +4,8 @@
;; define your group ;; 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 ;; the 'print-rounds' function determines if a particular arrangement of meetings
;; will nable everyon ein th egrouo to have met once. ;; will nable everyon ein th egrouo to have met once.
@ -16,37 +16,37 @@
;; show the scenario for week 1 ;; 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 ;; begin with seting up the meetings
(start-meetings fmba-group) (start-meetings some-group)
;; make a few rounds... ;; 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... ;; 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 ;; ...and by end of week 2
(printf "\nweek 1 & week 2 (scenario 1)\n\n") (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") (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") (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") (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)

View file

@ -5,12 +5,25 @@
(require racklog (require racklog
control control
math) 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 ;;logics
(define %has-met %empty-rel) ;; collection of meetings... (define %has-met %empty-rel) ;; collection of meetings...
(define %t0 %empty-rel) ;; tentative collection... (define %t0 %empty-rel) ;; tentative collection...
(define (meeting p1 p2) (define (meeting p1 p2)
(vecho "meeting between: ~a & ~a~n" p1 p2)
(%assert! %has-met () ((p1 p2))) (%assert! %has-met () ((p1 p2)))
(%assert! %has-met () ((p2 p1)))) (%assert! %has-met () ((p2 p1))))
@ -21,9 +34,9 @@
(meeting p1 p2)) (meeting p1 p2))
(define (meeting-3 p1 p2 p3) (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) (define (meeting-4 p1 p2 p3 p4)
(meeting-3 p1 p2 p3) (meeting-3 p1 p2 p3)
@ -41,7 +54,7 @@
;; assume everyone has "met" themselves ;; assume everyone has "met" themselves
(define (start-meetings group) (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)) (printf "starting with group: ~a~n~n" group))
(define (reset-meetings group) (define (reset-meetings group)
@ -60,7 +73,9 @@
(define (make-new-2 group) (define (make-new-2 group)
(cond (cond
((empty? group) '()) ((empty? group) '())
((> 4 (length group)) (list group)) ((> 2 (length group))
(begin
(printf "leftover: 1~n") (list group)))
(else (else
(let* ((p1 (car (shuffle group))) (let* ((p1 (car (shuffle group)))
(p2 (findf (lambda (x) (p2 (findf (lambda (x)
@ -75,7 +90,9 @@
(define (make-new-3 group) (define (make-new-3 group)
(cond (cond
((empty? group) '()) ((empty? group) '())
((> 4 (length group)) (list group)) ((> 3 (length group))
(begin
(printf "leftover: ~a~n" (length group)) (list group)))
(else (else
(let* ((p1 (car (shuffle group))) (let* ((p1 (car (shuffle group)))
(p2 (findf (lambda (x) (p2 (findf (lambda (x)
@ -144,20 +161,21 @@
;; keep trying until something "complete" is output ;; keep trying until something "complete" is output
;; determined by matching length as condition (TBC) ;; determined by matching length as condition (TBC)
(define escape-counter 100) (define escape-counter 1001)
(define (decrement-escape) (define (decrement-escape)
(printf ".")
(set! escape-counter (- escape-counter 1))) (set! escape-counter (- escape-counter 1)))
(define (reset-escape) (define (reset-escape)
(set! escape-counter 100)) (set! escape-counter 1001))
(define (ensure-new-5 group) (define (ensure-new-5 group)
(decrement-escape) (decrement-escape)
(if (eq? 0 escape-counter) (if (eq? 0 escape-counter)
(begin (begin
(reset-escape) (reset-escape)
(printf "escaped from loopland...~n") (vecho "escaped from loopland...~n")
'()) '())
(let ((t0 %has-met)) (let ((t0 %has-met))
(let ((c (make-new-5 group))) (let ((c (make-new-5 group)))
@ -173,7 +191,7 @@
(if (eq? 0 escape-counter) (if (eq? 0 escape-counter)
(begin (begin
(reset-escape) (reset-escape)
(printf "escaped from loopland...~n") (vecho "escaped from loopland...~n")
'()) '())
(let ((t0 %has-met)) (let ((t0 %has-met))
(let ((c (make-new-4 group))) (let ((c (make-new-4 group)))
@ -224,18 +242,20 @@
(else (cons (list (first l) (second l) (third l) (fourth l)) (else (cons (list (first l) (second l) (third l) (fourth l))
(group-fours (list-tail l 4))))))) (group-fours (list-tail l 4)))))))
;;; pairs ;;; pairs
(define (select-pairs-acc p1 p2 l) (define (select-pairs-acc p1 p2 l)
(vecho "trying: ~a and ~a from ~a\n" p1 p2 l)
(if (empty? l) '() (if (empty? l) '()
(if (have-they-met? (list p1 p2)) (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 (begin
;(printf "adding: ~a and ~a from ~a\n" p1 p2 l)
(meeting-2 p1 p2) (meeting-2 p1 p2)
(cons (list p1 p2) (select-pairs (remove* (list p1 p2) l))))))) (cons (list p1 p2) (select-pairs (remove* (list p1 p2) l)))))))
(define (select-pairs l) (define (select-pairs l)
(vecho "selecting pairs...~n")
(if (< (length l) 1) '() (if (< (length l) 1) '()
(let ((p1 (car l)) (let ((p1 (car l))
(p2 (car (shuffle l)))) (p2 (car (shuffle l))))
@ -243,9 +263,9 @@
(select-pairs-acc p1 p2 l)))) (select-pairs-acc p1 p2 l))))
;;; triples ;;; triples
(define (select-3fold-acc p1 p2 p3 l) (define (select-3fold-acc p1 p2 p3 l)
(vecho "trying: ~a, ~a and ~a from ~a\n" p1 p2 p3 l)
(if (empty? l) '() (if (empty? l) '()
(cond (cond
((have-they-met? (list p1 p2)) ((have-they-met? (list p1 p2))
@ -255,21 +275,21 @@
((have-they-met? (list p2 p3)) ((have-they-met? (list p2 p3))
(select-3fold-acc p1 p2 (car l) (remove p3 l))) (select-3fold-acc p1 p2 (car l) (remove p3 l)))
(else (begin (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) (meeting-3 p1 p2 p3)
(cons (list p1 p2 p3) (select-3fold (remove* (list p1 p2 p3) l)))))))) (cons (list p1 p2 p3) (select-3fold (remove* (list p1 p2 p3) l))))))))
(define (select-3fold l) (define (select-3fold l)
(vecho "selecting 3fold...~n")
(if (< (length l) 1) '() (if (< (length l) 1) '()
(let ((p1 (car l)) (let ((p1 (car l))
(p2 (car (shuffle l))) ;; maybe duplicate (p2 (car (shuffle l))) ;; maybe duplicate
(p3 (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)))) (select-3fold-acc p1 p2 p3 l))))
;;; fours
;;; fours
(define (select-4fold-acc p1 p2 p3 p4 l) (define (select-4fold-acc p1 p2 p3 p4 l)
(if (empty? l) '() (if (empty? l) '()
(cond (cond
@ -283,7 +303,6 @@
;(printf "adding: ~a, ~a and ~a from ~a\n" p1 p2 p3 l) ;(printf "adding: ~a, ~a and ~a from ~a\n" p1 p2 p3 l)
(meeting-4 p1 p2 p3 p4) (meeting-4 p1 p2 p3 p4)
(cons (list p1 p2 p3 p4) (select-3fold (remove* (list p1 p2 p3) l)))))))) (cons (list p1 p2 p3 p4) (select-3fold (remove* (list p1 p2 p3) l))))))))
(define (select-4fold l) (define (select-4fold l)
(if (< (length l) 1) '() (if (< (length l) 1) '()
@ -313,9 +332,12 @@
(define (print-test-rounds l n1 n2 n3) (define (print-test-rounds l n1 n2 n3)
(printf "There are ~a people (binomial ~a)\n" (length l) (binomial (length l) 2)) (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)) (cross-chatter (length l) n1 n2 n3))
@ -333,9 +355,11 @@
(define (print-rounds-of-2 group n) (define (print-rounds-of-2 group n)
(dotimes (x n) (dotimes (x n)
(printf "next round [2:~a]~n" (+ x 1)) (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"))) (printf "~n")))
(define (print-rounds-of-3 group n) (define (print-rounds-of-3 group n)
@ -368,9 +392,9 @@
(for-each (lambda (p0) (for-each (lambda (p0)
(printf "~a has met ~a others: ~a~n" (printf "~a has met ~a others: ~a~n"
p0 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) group)
(printf "~n")) (printf "~n"))