Script for effortless playing of `code 777`

code777.rkt

#lang typed/racket/base

(require racket/match
         racket/list
         racket/set
         bnf)

(Color     . ⩴ . 'green 'yellow 'black 'brown 'red 'pink 'blue)
(Name      . ≜ . Symbol)
(Piece     . ≜ . (Piece [digit : Integer] [color : Color]) #:ad-hoc)
(Piece-Set . ≜ . (HashTable Piece Positive-Integer))
(Config    . ≜ . (HashTable Name Piece-Set))
(State     . ≜ . (Listof Config))
(Event     . ≜ . (State → State))

(define Empty-Hand : Piece-Set (hash))

(define Standard-Game : Piece-Set
  (make-immutable-hash
   '([(1 . green) . 1]
     [(2 . yellow) . 2]
     [(3 . black) . 3]
     [(4 . brown) . 4]
     [(5 . red) . 4] [(5 . black) . 1]
     [(6 . pink) . 3] [(6 . green) . 3]
     [(7 . pink) . 1] [(7 . yellow) . 2] [(7 . blue) . 4])))

(: count-up (∀ (X) (Listof X) → (HashTable X Positive-Integer)))
;; Count up occurences of each element in list
(define (count-up xs)
  (for/fold ([m : (HashTable X Positive-Integer) (hash)]) ([x (in-list xs)])
    (match (hash-ref m x #f)
      [(? values n) (hash-set m x (+ 1 n))]
      [_            (hash-set m x 1)])))

(: ⊆ : Piece-Set Piece-Set → Boolean)
(define (⊆ set₁ set₂)
  (for/and ([(piece count) (in-hash set₁)])
    (<= count (hash-ref set₂ piece (λ () 0)))))

(: move-piece (case->
               [Piece-Set Piece Piece-Set → (Values Piece-Set Piece-Set)]
               [Config Name Name Piece → Config]))
;; Move piece from one set to the other
(define move-piece
  (case-lambda
    [(from piece to)
     (define from*
       (match (- (hash-ref from piece) 1)
         [(? positive? n) (hash-set from piece n)]
         [_               (hash-remove from piece)]))
     (define to*
       (match (hash-ref to piece #f)
         [(? values n) (hash-set to piece (+ 1 n))]
         [_            (hash-set to piece 1)]))
     (values from* to*)]
    [(cfg from to piece)
     (define-values (from* to*)
       (move-piece (hash-ref cfg from) piece (hash-ref cfg to)))
     (hash-set (hash-set cfg from from*) to to*)]))

(: start : (Listof (List Name Piece Piece Piece)) Piece-Set → State)
;; Initialize state space given pieces' distributions and observed pieces from other players
(define (start players distr)
  ;; Eliminate other seen pieces from other players
  (define init-config
    (for/fold ([config : Config (hash 'unused distr 'me Empty-Hand)])
              ([player (in-list players)])
      (match-define (cons name pieces) player)
      (for/fold ([config : Config (hash-set config name Empty-Hand)])
                ([piece (in-list pieces)])
        (move-piece config 'unused name piece))))

  ;; Enumerate all possible hands that I can have.
  ;; In a standard game, there can't be more than (22*21*20)/3! possible hands
  (define pool ; 22 pieces
    (for*/vector : (Vectorof Piece) ([(piece count) (in-hash (hash-ref init-config 'unused))]
                                     [_ (in-range count)])
      piece))
  (define (shift [cfg : Config] [i : Integer])
    (move-piece cfg 'unused 'me (vector-ref pool i)))
  (for*/list : State ([i (in-range (vector-length pool))]
                      [config₁ (in-value (shift init-config i))]
                      [j (in-range (+ 1 i) (vector-length pool))]
                      [config₂ (in-value (shift config₁ j))]
                      [k (in-range (+ 1 j) (vector-length pool))])
    (shift config₂ k)))

(: solve ([(Listof (List Name Piece Piece Piece)) (Listof Event)] [Piece-Set] . ->* . State))
;; Shrink to smallest set of possible configurations I can have,
;; given initial observations and a sequence of game events, which are one of:
;; - Person `X` tells about their observation of ther hands
;; - Person `X` screws up and gets a new hand
(define (solve players refinements [pool Standard-Game])
  (for/fold ([state : State (start players pool)])
            ([refine (in-list refinements)])
    (refine state)))

(: replace : Name (Listof Piece) → Event)
;; Person `name` screews up and get new `pieces`
(define ((replace name pieces) configs)
  (define piece-set (count-up pieces))
  (for/list : State ([config (in-list configs)]
                     #:when (⊆ piece-set (hash-ref config 'unused)))
    (for/fold ([config : Config (hash-set config name Empty-Hand)])
              ([piece (in-list pieces)])
      (define-values (pool hand)
        (move-piece (hash-ref config 'unused) piece (hash-ref config name)))
      (hash-set (hash-set config 'unused pool) name hand))))

(: says : Name (Config → Integer) (Integer Integer → Boolean) (Config → Integer) → Event)
;; Person `speaker` tells an observation of the form `_ (<|≤|=|>|≥|) _`
(define ((says speaker lhs op rhs) configs)
  (for*/list : State ([config (in-list configs)]
                      [config* (in-value (hash-remove (hash-remove config 'unused) speaker))]
                      #:when (op (lhs config*) (rhs config*)))
    config))

(: summarize : State → (HashTable (HashTable Integer Integer) Integer))
;; Summarize the current possible hands and their (un-normalized) probabilities
(define (summarize configs)
  (for*/fold ([m : (HashTable (HashTable Integer Integer) Integer) (hash)])
             ([config (in-list configs)])
    (define hand
      (for*/fold ([h : (HashTable Integer Integer) (hash)])
                 ([(piece count) (in-hash (hash-ref config 'me))]
                  [_ (in-range count)])
        (hash-update h (Piece-digit piece) add1 (λ () 0))))
    (hash-update m hand add1 (λ () 0))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; Combinators for common patterns
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(: on-rack (∀ (X) ((Listof Piece) → X) → Piece-Set → X))
(define ((on-rack handler) pieces)
  (handler (for*/list : (Listof Piece) ([(piece count) (in-hash pieces)]
                                        [_ (in-range count)])
             piece)))

(: on-pieces (∀ (X) ((Listof Piece) → X) → Config → X))
(define ((on-pieces handler) cfg)
  (handler
   (for*/list : (Listof Piece) ([rack (in-hash-values cfg)]
                                [(piece count) (in-hash rack)]
                                [_ (in-range count)])
     piece)))

(: count-rack : (Piece-Set → Boolean) → Config → Integer)
(define ((count-rack sat?) cfg)
  (for/sum : Integer ([hand (in-hash-values cfg)] #:when (sat? hand))
    1))

(: sum-digits : (Listof Piece) → Integer)
(define (sum-digits ps) (apply + (map Piece-digit ps)))

(: count-by (∀ (X Y) (Y → Boolean) (X → Y) → (Listof X) → Integer))
(define ((count-by p? f) xs) (length (filter-map (compose p? f) xs)))

(: count-uniques (∀ (X Y) (X → Y) → (Listof X) → Integer))
(define ((count-uniques f) xs) (set-count (list->set (map f xs))))

(: consec? : (Listof Piece) → Boolean)
(define (consec? xs)
  (let check ([xs (sort (map Piece-digit xs) <)])
    (match xs
      [(or (list) (list _)) #t]
      [(cons x₁ (and xs* (cons x₂ _))) (and (= x₂ (+ 1 x₁)) (check xs*))])))

(: just (∀ (X) X → Any → X))
(define ((just x) _) x)

(define-syntax-rule (with-inits (player ...) event ...)
  (solve (list 'player ...) (list event ...)))

(module+ test
  (require typed/rackunit)
  
  (define mid-game ;; pretend mine are {(7 . pink) (7 . yellow) (7 . yellow)}
    (with-inits ([Wes (1 . green) (2 . yellow) (3 . black)]
                 [Tom (4 . brown) (5 . red) (6 . pink)])
      
      ;; Tom says there are 4 unique colors
      (says 'Tom (on-pieces (count-uniques Piece-color)) = (just 4))
      
      ;; Wes says there's 1 rack with consecutive digits
      (says 'Wes (count-rack (on-rack consec?)) = (just 1))
      
      ;; Tom screws up and gets a new hand
      (replace 'Tom '((6 . pink) (6 . pink) (7 . blue)))
      
      ;; Tom confirms even numbers are no more than odd ones
      (says 'Tom
            (on-pieces (count-by even? Piece-digit))
            <=
            (on-pieces (count-by odd? Piece-digit)))
      
      ;; Wes says there are 2 racks whose sum is at least 13
      (says 'Wes
            (count-rack ((inst on-rack Boolean)
                         (λ (pieces) (>= (sum-digits pieces) 13))))
            =
            (just 2))

      ;; Game goes on ...
      ))

  ;; The true answer better still be in there
  (check-true (hash-has-key? (summarize mid-game) '#hash((7 . 3))))

  ;; The search space better have shrinked from original
  (check-true (< (length mid-game) (/ (* 22 21 20) 6))))