extra/wordlet/wordlet.factor

   1 ! Copyright (C) 2022 Doug Coleman.
   2 ! See https://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 math.order random ranges sequences
   7 sequences.extras sets sorting.specification 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     [ [ = ] [ drop 1string ] { } 2reject-map-as ] 2keep
  29     [
  30         [ nip 1string ] [ = ] 2bi
  31         [ COLOR: green ]
  32         [
  33             2dup member-of?
  34             [ [ remove-first-of ] [ 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 : remaining-chars ( game -- chars )
  48     [ secret-word>> ] [ guesses>> ] bi [
  49         guess>chars
  50     ] with map concat members
  51     [ background of ] assoc-map
  52     [ drop ] collect-value-by
  53     [ [ color>n ] zip-with { >=< } sort-values-with-spec 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     remaining-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/f )
  65     "guess: " write
  66     readln >lower dup [
  67         dup length 5 =
  68         [ " needs to have 5 letters" append print read-guess ] unless
  69         dup word-list in?
  70         [ " not in the word list" append print read-guess ] unless
  71     ] when ;
  72
  73 : check-winner? ( game -- ? )
  74     [ secret-word>> ] [ guesses>> ?last ] bi = ;
  75
  76 : print-secret ( game color -- )
  77     [ secret-word>> ] [ background associate ] bi* format nl ;
  78
  79 : maybe-stop? ( game -- ? )
  80     [ guesses>> length ] [ chances>> ] bi >= ;
  81
  82 : play-wordlet ( game -- )
  83     dup maybe-stop? [
  84         COLOR: red print-secret
  85     ] [
  86         {
  87             [ print-guesses ]
  88             [ print-remaining-chars ]
  89             [ [ read-guess ] dip guesses>> push ]
  90             [
  91                 dup guesses>> last [
  92                     dup check-winner?
  93                     [ COLOR: green print-secret ]
  94                     [ play-wordlet ] if
  95                 ] [
  96                     "you gave up, the word was " write COLOR: red print-secret
  97                 ] if
  98             ]
  99         } cleave
 100     ] if ;
 101
 102 : play-random-wordlet-game ( -- )
 103     "Wordlet Started" print
 104     word-list random 6 <wordlet-game> play-wordlet ;
 105
 106 MAIN: play-random-wordlet-game