extra/wordlet/wordlet.factor

   1 ! Copyright (C) 2022 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays ascii assocs assocs.extras base91 colors
   4 combinators hashtables io io.encodings.binary
   5 io.encodings.string io.encodings.utf8 io.files io.styles kernel
   6 literals math random ranges sequences sequences.extras sets
   7 sorting splitting strings ;
   8 IN: wordlet
   9
  10 <PRIVATE
  11
  12 CONSTANT: word-list $[
  13     "vocab:wordlet/word-list.txt" binary file-contents
  14     base91> utf8 decode "\n" split fast-set
  15 ]
  16
  17 PRIVATE>
  18
  19 TUPLE: wordlet-game secret-word chances guesses ;
  20
  21 : <wordlet-game> ( secret-word chances -- wordlet-game )
  22     wordlet-game new
  23         swap >>chances
  24         swap >>secret-word
  25         V{ } clone >>guesses ; inline
  26
  27 : guess>chars ( secret guess -- seq )
  28     [ zip [ first2 = not ] filter keys [ 1string ] map ] 2keep
  29     [
  30         [ nip 1string ] [ = ] 2bi
  31         [ COLOR: green ]
  32         [
  33             2dup swap member?
  34             [ [ swap remove-first ] [ COLOR: yellow ] bi ]
  35             [ COLOR: gray ] if
  36         ] if
  37         background associate 2array
  38     ] { } 2map-as nip ;
  39
  40 : color>n ( color -- n )
  41     {
  42         { COLOR: gray [ 1 ] }
  43         { COLOR: yellow [ 2 ] }
  44         { COLOR: green [ 3 ] }
  45     } case ;
  46
  47 : reamining-chars ( game -- chars )
  48     [ secret-word>> ] [ guesses>> ] bi [
  49        guess>chars
  50     ] with map concat members
  51     [ background of ] assoc-map
  52     [ first ] collect-value-by
  53     [ [ color>n ] zip-with sort-values reverse first first ] assoc-map
  54     CHAR: a CHAR: z [a..b] [ 1string COLOR: white ] { } map>assoc [ or ] assoc-merge ;
  55
  56 : print-remaining-chars ( game -- )
  57     reamining-chars [ background associate format ] assoc-each nl ;
  58
  59 : print-guesses ( game -- )
  60     [ secret-word>> ] [ guesses>> ] bi [
  61         guess>chars [ format ] assoc-each nl
  62     ] with each nl ;
  63
  64 : read-guess ( -- guess )
  65     "guess: " write
  66     readln >lower dup length 5 =
  67     [ " needs to have 5 letters" append print read-guess ] unless
  68     dup word-list in?
  69     [ " not in the word list" append print read-guess ] unless ;
  70
  71 : check-winner? ( game -- ? )
  72     [ secret-word>> ] [ guesses>> ?last ] bi = ;
  73
  74 : print-secret ( game color -- )
  75     [ secret-word>> ] [ background associate ] bi* format nl ;
  76
  77 : maybe-stop? ( game -- ? )
  78     [ guesses>> length ] [ chances>> ] bi >= ;
  79
  80 : play-wordlet ( game -- )
  81     dup maybe-stop? [
  82         COLOR: red print-secret
  83     ] [
  84         {
  85             [ print-guesses ]
  86             [ print-remaining-chars ]
  87             [ [ read-guess ] dip guesses>> push ]
  88             [
  89                 dup check-winner?
  90                 [ COLOR: green print-secret ]
  91                 [ play-wordlet ] if
  92             ]
  93         } cleave
  94     ] if ;
  95
  96 : play-random-wordlet-game ( -- )
  97     "wordlet Started" print
  98     word-list random 6 <wordlet-game> play-wordlet ;
  99
 100 MAIN: play-random-wordlet-game