Create a gist now

Instantly share code, notes, and snippets.

@nfunato /tofu.fth
Last active Dec 11, 2015

What would you like to do?
The "Retro" Tofu Shop Game in Iscandar (in ANS Forth)
\ -*- Mode: Forth -*-
\ The Tofu Shop Game in Iscandar
\ Copyright (C) 1978-2012 by Nobuhide Tsuda
\ See also http://vivi.dyndns.org/tofu/tofu.html, and
\ the definition of the word SHOW-CREDIT below.
\ This Forth version is written only with ANS94-compiant words, and
\ tested on gforth 0.7.0 (64bit word) on Mac OSx Lion.
\ ===================================================================
\ General utilities
: 3dup 2 pick 2 pick 2 pick ;
: 3drop 2drop drop ;
: bits-in-word ( -- +n ) 1 cells 8 * ;
\ compute modified-julian-date and time-of-day-in-ms (for simple randomseed)
\ N.B. mjd = d + floor(30.59(m-2)) + floor(365.25*y) + y/400 - y/100 - 678912
: adjust-month-year ( m y -- m' y' ) over 3 < if swap 12 + swap 1- then ;
: mjd ( d m y -- mjd )
adjust-month-year \ change jan/feb to 13/14 of the previous year
>r 2 - 3059 * 100 / + r@ 1461 * 4 / + r@ 400 / + r> 100 / - 678912 - ;
: tod ( s m h -- tod ) 60 * + 60 * + 1000 * ;
: tod-mjd ( -- tod mjd ) time&date mjd >r tod r> ;
\ 16bit Linear congruential PRNG (not so good, but extremely simple)
\ here (1021,41) is from Alan Winfield's "The Complete FORTH".
\ you can also use (31421,6927) which is from Leo Brodie's "Starting Forth".
variable *rnd*
here *rnd* ! \ using HERE as a default seed
: rngseed ( -- u ) tod-mjd + 255 4 lshift and ; \ get middle 8bit
: randomize ( -- ) rngseed *rnd* ! ;
: random ( -- u ) *rnd* @ 1021 * 41 + dup *rnd* ! ;
: >random ( u1 -- u2 ) \ u2 ranges over [0 u1)
random
bits-in-word 16 - lshift
um* nip ;
: rand100 ( -- u ) 101 >random ; \ return randomized integer in [0,100]
\ y-or-n-p, yes-or-no-p
: clear-input begin key? while key drop repeat ;
: prompt cr type 2>r c" ) " r> c" or " r> c" (" 5 0 do count type loop ;
: compare-cs ( ca u cs -- f ) count compare ;
: x-or-y-p ( ca u cs-x cs-y -- f )
clear-input
locals| cs-y cs-x u ca |
begin
cs-x cs-y ca u prompt
pad dup 10 accept \ note: gforth's ACCEPT echo-backs input
2dup cs-x compare-cs 0= if
2drop true true
else
cs-y compare-cs 0= if false true else false then
then
until ;
: y-or-n-p ( ca u -- f ) c" y" c" n" x-or-y-p ;
: yes-or-no-p ( ca u -- f ) c" yes" c" no" x-or-y-p ;
\ ===================================================================
\ Display/Input utilities
variable *ms-count*
10 *ms-count* !
: npauses ( u -- ) *ms-count* @ * ms ;
variable *post-disp-pause-p*
true *post-disp-pause-p* !
: npauses-opt ( u --) *post-disp-pause-p* @ if npauses else drop then ;
\ support for TheMatrix mode
variable *slow-tty-mode-p*
true *slow-tty-mode-p* !
: disp1 ( ca u -- ) 0 ?do dup i + c@ emit 1 npauses loop drop ;
: disp ( ca u -- ) *slow-tty-mode-p* @ if disp1 else type then ;
: disp-cs ( cs -- ) count disp ;
: cr-disp ( ca u -- ) cr disp ;
: cr-type ( ca u -- ) cr type ;
: prompt-range ( cs min max -- )
rot disp-cs swap
space [char] ( emit space . s" -- " disp . [char] ) emit space ;
: get-int ( -- n ) 0. pad dup 6 accept >number 2drop d>s ;
: get-int-within-range ( cs min max -- n )
0 begin
drop 3dup prompt-range
get-int 3dup -rot 1+ within
until >r 3drop r> ;
\ ===================================================================
\ Some explanations of the game
: show-credit ( -- )
s" The Tofu Shop Game in Iscandar (ANS Forth Version)" cr-type
s" Copyright (C) 1978-2012 by Nobuhide Tsuda" cr-type
s" Port to Perl and add TheMatrix mode by Keiichiroh Nagano" cr-type
s" Port to CL by Shozo Takeoka" cr-type
s" Revised CL version, https://gist.github.com/4249102, and " cr-type
s" this Forth version by Nobuhiko Funato" cr-type
cr ;
: cd cr-disp ;
: display-goal ( -- )
s" Welcome to the planet ISCANDAR !" cd
s" You are the person who runs a tofu shop to make money for the cost " cd
s" of returning your mother planet, the EARTH." cd
s" (If you don't know well about ISCANDAR, you may want to see " cd
s" http://en.wikipedia.org/wiki/Space_Battleship_Yamato_planets .)" cd
s" But, on the other side of the street, there is the other shop run " cd
s" by a computer. The goal of the game is to compete against the " cd
s" computer for earning 30,000-yen sooner, necessary amount of money " cd
s" to the EARTH. The cash for each initially starts from 5,000-yen." cd
s" Here the cost price of a tofu is 40-yen, and the retail price of a " cd
s" tofu is 50-yen. Daily sales depend on the weather, i.e. " cd
s" upto 500 on sunny, upto 300 on cloudy, and upto 100 on rainy days." cd
s" Tofu spoils rapidly, so unsold tofus in a day must be thrown away." cd
s" Hence you should decide how many tofus you make for the next day, " cd
s" with close watching the weather forecast for tomorrow." cd
cr ;
\ ===================================================================
\ Domain knowledge, i.e. the parameters embedded in the rule of the game
30000 constant $saving-target
5000 constant $initial-cash
50 constant $unit-retail-price
40 constant $unit-cost-price
: calculate-profit ( prepared-stock sales-limit -- profit )
over >r min ( sales-amount-in-unit ; r: prepared-stock )
$unit-retail-price m* \ total sales
$unit-cost-price r> m* \ total cost including unsold items
d- d>s \ subract the latter from the former,
; \ since all unsold items will be abandoned
\ weather
0 constant $sunny
1 constant $cloudy
2 constant $rainy
: sales-limit-for-weather ( weather -- sales-limit-in-unit )
case
$sunny of 500 endof
$cloudy of 300 endof
$rainy of 100 endof
abort" sales-limit-for-weather"
endcase ;
\ ===================================================================
\ Essential descriptions of the game
\ winner
0 constant $not-endgame
1 constant $game-is-draw
2 constant $winner-is-you
3 constant $winner-is-com
: make-bar ( +n ch -- ca +n )
>r pad swap 2dup r> ( ca +n ca +n ch )
fill ( ca +n ) \ where ca[0]..ca[n-1] are filled by ch
;
: cash->no-money/money ( cash -- no-money money )
1000 /
30 over - 0 max
swap
;
: disp-money-with-bar ( name-cs cash -- )
dup rot
cr 2 spaces
disp-cs \ name-cs
s" : " disp
5 u.r \ cash
s" -yen " disp
cash->no-money/money
[char] # make-bar disp \ money-bar
[char] - make-bar disp \ no-money-bar
;
: display-money ( you com -- )
>r >r
s" display-money: " cr-type
c" you" r> disp-money-with-bar
c" com" r> disp-money-with-bar
cr ;
: who-is-winner' ( you com -- you com winner )
2dup min $saving-target > if $game-is-draw exit then
2dup max 0 <= if $game-is-draw exit then
2dup 0 <= swap $saving-target > or if $winner-is-you exit then
2dup $saving-target > swap 0 <= or if $winner-is-com exit then
$not-endgame
;
: who-is-winner ( you com -- winner )
who-is-winner' >r 2drop r> ;
: scaling ( u ) 10 * 25 / ;
: display-forecast ( sPr cPr rPr -- )
over 3 pick ( sPr cPr rPr cPr sPr )
s" Tomorrow weather: " cr-disp
s" Sunny " disp 2 u.r
s" % , Cloudy " disp 2 u.r
s" % , Rainy " disp 2 u.r
s" %" disp cr
scaling >r scaling >r ( r: scaled-cPr scaled-sPr )
100 scaling 2r@ + - 2r> ( scaled-rPr scaled-cPr scaled-sPr )
18 spaces
[char] O make-bar disp
[char] ^ make-bar disp
[char] X make-bar disp
cr
;
: get-weather-forecast ( -- sPr cPr rPr )
rand100 rand100 2>r
100 2r@ max - \ sunny-Pr
2r> min \ rainy-Pr
2dup + 100 swap - \ cloudy-Pr
swap
3dup display-forecast ;
: get-your-plan ( _sPr _cPr _rPr you -- your-plan )
>r 3drop
c" How many tofus will you make?"
1
r> 40 / \ dividing cash of "you" by 40 to get limit
get-int-within-range ;
: get-com's-plan ( sPr _cPr rPr com -- com's-plan )
40 / >r \ save limit to rstack
nip swap ( rPr sPr ; r: limit )
50 > if
drop 500
else
30 >= if 100 else 300 then
then
r> min ( com-plan )
s" Computer will make " cr-disp dup . space s" tofus." disp ;
: weather->mood/name ( weather -- mood-cs name-cs )
case
$sunny of c" \(^o^)/" c" sunny " endof
$cloudy of c" (~_~) " c" cloudy" endof
$rainy of c" (;_;) " c" rainy " endof
abort" weather->mood/name"
endcase
;
: print-ellipsis-slowly ( -- )
85 60 45
3 0 do
s" . " disp
npauses-opt
loop
space
;
: display-weather ( weather -- )
s" Today's weather is " cr-disp
print-ellipsis-slowly
weather->mood/name
disp-cs
65 npauses-opt
disp-cs
cr
;
: get-next-weather ( _sPr cPr rPr -- weather )
rot drop ( cPr rPr )
rand100 2dup ( cPr rPr sunny-rnd rPr sunny-rnd )
> if
3drop $rainy
else
-rot + ( sunny-rnd cPr+rPr )
<= if $cloudy else $sunny then
then
dup display-weather ;
: update-cash ( sales-limit cash stock -- cash' )
rot calculate-profit + ;
: proceed-1day-session ( day you com -- day' you' com' )
locals| com you day |
get-weather-forecast ( sPr cPr rPr )
3dup you get-your-plan >r ( sPr cPr rPr ; r: your-plan )
3dup com get-com's-plan >r ( sPr cPr rPr ; r: your-plan com's-plan )
cr s" * * * * * * Day " cr-disp day 2 u.r s" * * * * * *" disp
get-next-weather ( weather ; r: your-plan com's-plan )
sales-limit-for-weather ( limit ; r: your-plan com's-plan )
day 1+ swap dup ( day+1 limit limit ; r: your-plan com's-plan )
com r> update-cash swap ( day+1 com' limit ; r: your-plan )
you r> update-cash swap ( day+1 you' com' )
;
: play-a-game ( -- winner )
randomize
1 $initial-cash $initial-cash
begin ( day you com )
2dup display-money
2dup who-is-winner
dup $not-endgame = ( day you com winner bool )
while
drop ( day you com )
proceed-1day-session ( day' you' com' )
repeat
>r 3drop r> \ returns winner
;
: main ( -- )
show-credit
s" Do you want TheMatrix display mode?" y-or-n-p *slow-tty-mode-p* !
s" Do you want to read the rule of the game?" y-or-n-p if display-goal then
cr
begin
play-a-game case
$game-is-draw of s" It is a draw." cr-type endof
$winner-is-you of s" You win!" cr-type endof
$winner-is-com of s" Computer win!" cr-type endof
abort" main"
endcase
s" Play another game?" yes-or-no-p
while
repeat ;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment