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