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 math.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 ) dup bulls>> 1 + >>bulls ;
  41 : inc-cows ( score -- score ) dup cows>> 1 + >>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 : print-sum ( score -- str )
  70     dup bulls>> number>string "Bulls: " swap append swap cows>> number>string
  71     " Cows: " swap 3append "\n" append ;
  72
  73 : (validate-readln) ( str -- ? ) dup length 4 = not swap [ letter? ] all? or ;
  74
  75 : validate-readln ( -- str )
  76     readln dup (validate-readln)
  77     [ "Invalid input.\nPlease enter a valid 4 digit number: "
  78       write flush drop validate-readln ]
  79     when ;
  80
  81 : win ( -- ) "\nYou've won! Good job. You're so smart." print flush ;
  82
  83 : main-loop ( x -- )
  84     "Enter a 4 digit number: " write flush validate-readln num>hash swap
  85     [ sum-score swap print-sum print flush ] keep swap not
  86     [ main-loop ] [ drop win ] if ;
  87
  88 : bulls-and-cows-main ( -- ) new-number drop narr>nhash main-loop ;
  89
  90 MAIN: bulls-and-cows-main