extra/rosetta-code/bulls-and-cows/bulls-and-cows.factor

   1 ! Copyright (c) 2012 Anonymous
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators fry grouping hashtables
   4 kernel locals math math.parser ranges random sequences
   5 strings io ascii ;
   6 IN: rosetta-code.bulls-and-cows
   7
   8 ! http://rosettacode.org/wiki/Bulls_and_cows
   9
  10 ! This is an old game played with pencil and paper that was
  11 ! later implemented on computer.
  12
  13 ! The task is for the program to create a four digit random
  14 ! number from the digits 1 to 9, without duplication. The program
  15 ! should ask for guesses to this number, reject guesses that are
  16 ! malformed, then print the score for the guess.
  17
  18 ! The score is computed as:
  19
  20 ! 1. The player wins if the guess is the same as the randomly
  21 !    chosen number, and the program ends.
  22
  23 ! 2. A score of one bull is accumulated for each digit in the
  24 !    guess that equals the corresponding digit in the randomly
  25 !    chosen initial number.
  26
  27 ! 3. A score of one cow is accumulated for each digit in the
  28 !    guess that also appears in the randomly chosen number, but in
  29 !    the wrong position.
  30
  31 TUPLE: score bulls cows ;
  32 : <score> ( -- score ) 0 0 score boa ;
  33
  34 TUPLE: cow ;
  35 : <cow> ( -- cow ) cow new ;
  36
  37 TUPLE: bull ;
  38 : <bull> ( -- bull ) bull new ;
  39
  40 : inc-bulls ( score -- score ) [ 1 + ] change-bulls ;
  41 : inc-cows ( score -- score ) [ 1 + ] change-cows ;
  42
  43 : random-nums ( -- seq ) 9 [1..b] 4 sample ;
  44
  45 : add-digits ( seq -- n ) 0 [ swap 10 * + ] reduce number>string ;
  46
  47 : new-number ( -- n narr ) random-nums dup add-digits ;
  48
  49 : narr>nhash ( narr -- nhash ) { 1 2 3 4 } swap zip ;
  50
  51 : num>hash ( n -- hash )
  52     [ digit> ] { } map-as narr>nhash ;
  53
  54 :: cow-or-bull ( n g -- arr )
  55     {
  56         { [ n first g at n second = ] [ <bull> ] }
  57         { [ n second g value? ] [ <cow> ] }
  58         [ f ]
  59     } cond ;
  60
  61 : add-to-score ( arr -- score )
  62    <score> [ bull? [ inc-bulls ] [ inc-cows ] if ] reduce ;
  63
  64 : check-win ( score -- ? ) bulls>> 4 = ;
  65
  66 : sum-score ( n g -- score ? )
  67     '[ _ cow-or-bull ] map sift add-to-score dup check-win ;
  68
  69 : score-to-answer ( score -- str )
  70     [ bulls>> number>string "Bulls: " prepend ]
  71     [ cows>> number>string " Cows: " prepend ] bi "\n" glue ;
  72
  73 : (validate-readln) ( str -- ? )
  74     [ length 4 = not ]
  75     [ [ letter? ] all? ] bi or ;
  76
  77 : validate-readln ( -- str )
  78     readln dup (validate-readln)
  79     [
  80         "Invalid input.\nPlease enter a valid 4 digit number: "
  81         write flush drop validate-readln
  82     ] when ;
  83
  84 : win ( -- ) "You've won! Good job. You're so smart." print flush ;
  85
  86 : main-loop ( x -- )
  87     "Enter a 4 digit number: " write flush validate-readln num>hash swap
  88     [ sum-score swap score-to-answer print flush ] keep swap not
  89     [ main-loop ] [ drop win ] if ;
  90
  91 : bulls-and-cows-main ( -- ) new-number drop narr>nhash main-loop ;
  92
  93 MAIN: bulls-and-cows-main