Skip to content

Instantly share code, notes, and snippets.

@nfunato

nfunato/00_history.org

Last active Nov 29, 2020
Embed
What would you like to do?
The "Retro" Tofu Shop Game in Iscandar (in ANS Forth)

Revision History – the “Retro” tofu shop game in Iscandar (in ANS Forth)

2020-11-15

  • Thinking Forth を (初めて)通読して、痛く反省したので refactoring してみた (tofu.fthのみ)
  • ファイル構成等の詳細は、tofu.fth の heading comment を参照 (なお、旧版(2013,2019)のgist filesは 目の毒なので、このgist entryの表向きからは消した)
  • TFを読んで思ったこと/悟ったことは以下

    – Forthプログラムでは stack jugglingするよりは、(グローバル)変数を使った方が良い場合もある。

    – stack effectにおいて、以前の版では 専らcaller saveになるようにしていたが、必ずしもそうでなくて良いようだ。 特に、上位の呼び出し階層において、ワード呼び出しの直前直後で argument save や stack jugglingだけのための ワードが現れない素直な point free styleになることを優先するのが良さげである。 (ただまあ何らかの法則はあった方が良いのかもしれない)

    – ワード .” を再定義した。これは初版(2013年)でも考えたのだが、non-portableになる気がしてやってなかった。 ところが、TFに「再定義推奨なんだけど、FIG83だとstate dependentの絡みで処理系依存になるよ」みたいなことが書いてある。 で、gforthのソースを読んでみたところ、現代でも再定義はnon-portableになるのが避けがたいように思えたので、それならと再定義してみた。 (しかし、gforthがnon-portableな書き方をしているのは、できないからという理由ではないかもしれず、上記の観測は誤っているかもしれない)

    で .” の定義は gforth依存ということになるが、 .” は(ワードtypeなんかと違って)コロン定義相当だろうし、依存しているのは 定義の内容というよりは それを処理系に伝える部分なので、他の処理系でも何か書く方法はある筈だと思う。

    – 少なくとも上記3点の効果で、以前よりはずいぶん読み易くなったのではないか。 標準FORTHの基本ワード(http://lars.nocrew.org/dpans/dpansf.htm )を識別できるくらいの人なら十分読めそうに思う。

    ちなみにFORTHの定義はボトムアップにしか配置できないので、大意を把握するには 下から上に向かって読む。

    – 一方で、手を抜いてあってすら 表示ルーチン(.xxxのような名前の奴ね)の定義ばっかりになってしまったような感じがする。 Common Lispならば format関数一発のような奴を長々と書くのは辛い…

    自分はFORTHという言語の面白さ(1970年代にOSすら無いようなbarebone machine上で、とある方向性においては 多少の先進性を得られる感じ)を味わうこともできるのだが、これに共感できるのは 当時の不便さを体感したオッサンくらいかもしれない。

2019-04-30

  • 何故か気が向いて、大幅に改版

    CLから安直に移植したことで、Forthとしては不自然だったところを修正した (特に、CLのcond式はForthに無いので、下手に表現するとifの入れ子が複数段になり、 stack jugglingが絡むと絶望的に読み難くなるように思う)

    長期休暇に逃避行動で書いていることが良く分かる…

  • ソースは tofu.fth とは別に lib.fth, anew.fth を登録

    libは一般的でライブラリになりそうなワードを分離したもの

    anewは同名の有名ユーティリティで、プリロードする必要がある

2013-01-26

  • お正月にお屠蘇飲みながら書いてみたForthへの移植を登録

    Forthは◯十年前に、1年半ほど楽しんで使っていたが、書くのはそれ以来かもしれない

    ANS仕様のForthは初めてで、仕様書を眺める時間が大半だった

  • ソースは tofu.fth のみ
\ -*- Mode: Forth -*-
\ Main program of the Tofu Shop Game in Iscandar
\
\ Copyright (C) 1978-2012 for the original version by Nobuhide Tsuda
\ See also http://vivi.dyndns.org/tofu/tofu.html for license
\
\ Copyright (C) 2013,2019,2020 for this Forth version by Nobuhiko Funato,
\ which is meant to be almost ANS94-compliant, and tested on gforth 0.7.0
\ and 0.7.3 (64bit word, Mac OSX).
\
\ Usage on gforth: $ gforth prelude.fth tofu.fth
\
\ Source files are prelude.fth, anew.fth, editor.fth, tofu_lib.fth,
\ and tofu.fth. Typically they can be placed in the same directories
\ for the usage above. The first three files are very short utilities,
\ and non-essential for this application.
\
\ prelude.fth just loads anew.fth and editor.fth
\ anew.fth gives Wil Baden's utility word ANEW (need to be preloaded)
\ editor.fth gives a word EDITOR which invokes an external editor vim
\ tofu_lib.fth gives general (and non-app-oriented) utility words
\ tofu.fth this file
\ ToDo (from more important to less):
\ - TWEAK GET-NEXT-WEATHER TO REDUCE PROFIT MODERATELY
\ - make get-com-plan' wiser
ANEW --TOFU--
: this-file s" tofu.fth" ;
' this-file is editor-target
s" tofu_lib.fth" included
\ ===================================================================
\ Display utilities
variable 'ms-count
7 'ms-count !
: pauses ( u -- ) ?dup if 'ms-count @ * ms else drop then ;
: 1pause 1 pauses ; \ pause one unit of time
\ slow-tty-mode
variable 'slow-tty?
'slow-tty? on
: ?pauses ( u -- ) 'slow-tty? @ if pauses else drop then ;
: emit' ( x -- ) 'slow-tty? @ if 1pause then emit ;
: type' ( ca u -- ) ?dup if bounds do i c@ emit' loop else drop then ;
: .nchars ( n ch -- ) swap 0 ?do dup emit' loop drop ;
\ the following three lines defines
\ : ." ( "w" -- ) [char] " parse type' ;
\ in gforth dependent way
:noname '"' parse type' ;
:noname '"' parse postpone sliteral postpone type' ;
interpret/compile: ."
\ ===================================================================
\ Some explanations of the game
: show-credit ( -- )
cr
cr ." The Tofu Shop Game in Iscandar (ANS Forth Version)"
cr ." Copyright (C) 1978-2012 for the original version by Nobuhide Tsuda"
cr ." Copyright (C) 2013,2019,2020 for the Forth version by Nobuhiko Funato"
cr ;
: show-goal ( -- )
cr
cr ." Welcome to the planet ISCANDAR !"
cr ." You are the person who runs a tofu shop to make money for the"
cr ." cost of returning your mother planet, the EARTH."
cr ." (If you don't know well about ISCANDAR, you may want to see"
cr ." http://en.wikipedia.org/wiki/Space_Battleship_Yamato_planets .)"
cr ." But, on the other side of the street, there is the other shop run"
cr ." by a computer. The goal of the game is to compete against the "
cr ." computer for earning 30,000-yen sooner, necessary amount of money"
cr ." to the EARTH. The cash for each initially starts from 5,000-yen."
cr ." Here the cost price of a tofu is 40-yen, and the retail price of"
cr ." a tofu is 50-yen. Daily sales depend on the weather, i.e. "
cr ." upto 500 on sunny, upto 300 on cloudy, and upto 100 on rainy days."
cr ." Tofu spoils rapidly, so unsold tofus in a day must be thrown away."
cr ." Hence you should decide how many tofus you make for the next day, "
cr ." with close watching the weather forecast for tomorrow."
cr ;
\ ===================================================================
\ And the main logic of the game
\ Some predefined money amounts
40 constant $UNIT_COST_PRICE
50 constant $UNIT_RETAIL_PRICE
5000 constant $INITIAL_CASH
30000 constant $SAVINGS_TARGET
: continue-game? ( cash -- bool )
\ underflow means bankruptcy, overflow means goal
1 $SAVINGS_TARGET within ;
: clip-cash-range ( cash -- cash' )
\ normalize cash, for cash<=0 to 0 and for $MAX<=cash to $MAX
\ (used in .CASH-BAR and COMPARE-CASH)
>r 0 $SAVINGS_TARGET r> clip-int ;
: max-tofus-to-make ( cash -- n )
\ make at least one tofu even insufficient budget, and then
\ go into bankrupt at the next settlement
$UNIT_COST_PRICE / 1 max ;
: calculate-profit ( sales-limit stock -- profit )
dup >r ( sales-limit stock ; r: stock )
min $UNIT_RETAIL_PRICE m* \ get real sales proceeds
r> $UNIT_COST_PRICE m* \ get sales cost, including unsold tofus
\ (note: unsold tofus will be abandoned)
d- d>s \ get profit
;
\ -------------------------------------------------------------------
enum Weather
Weather SUNNY
Weather CLOUDY
Weather RAINY
\ ...................................................................
\ Gforth-specific structure version, cf.
\ www.complang.tuwien.ac.at/forth/gforth/Docs-html/Structures.html#Structures
\ struct
\ cell% field weather-name
\ cell% field weather-mood
\ cell% field weather-sales
\ end-struct weather%
\ : weathers weather% %size * ;
\ create weather-vec weather% 3 * %allot drop
\ ...................................................................
\ Forth200x structure
\ (gforth way is somewhat better at the point of alignment consideration)
begin-structure weather%
field: weather-name
field: weather-mood
field: weather-sales
end-structure
: weathers weather% * ; \ strictly alignment should be taken into consideration
create weather-vec weather% 3 * allot
\ ...................................................................
\ common part for Gforth and Forth200x
: wv@ ( weather-idx -- wv-entry ) weathers weather-vec + ;
: init-weather
3 roll wv@ >r
r@ weather-sales ! r@ weather-mood ! r> weather-name ! ;
: init-weathers
SUNNY c" sunny " c" \(^o^)/" 500 init-weather
CLOUDY c" cloudy" c" (~_~) " 300 init-weather
RAINY c" rainy " c" (;_;) " 100 init-weather ;
init-weathers
: weather->name ( weather-idx -- name-cs ) wv@ weather-name @ ;
: weather->mood ( weather-idx -- mood-cs ) wv@ weather-mood @ ;
: weather->sales ( weather-idx -- sales-limit ) wv@ weather-sales @ ;
: .weather ( weather -- )
cr ." Today's weather is "
99 80 70 \ consumed by ?PAUSES below
3 0 do ?pauses ." . " loop
dup
weather->name 85 ?pauses count type
weather->mood 65 ?pauses count type
;
: get-rPr/cPr/sPr ( rPr sPr total -- rPr cPr sPr )
>r 2dup + r> swap - swap ; \ regenerate cPr
: get-next-weather' ( rPr sPr -- weather )
\ after regenerate cPr, remake sPr at random
100 get-rPr/cPr/sPr ( rPr cPr sPr )
drop rand100 ( rPr cPr sPr' )
locals| sPr' cPr rPr |
sPr' rPr <= if RAINY exit then
sPr' rPr cPr + <= if CLOUDY exit then
SUNNY
;
: get-next-weather ( rPr sPr -- weather )
get-next-weather' dup .weather ;
\ -------------------------------------------------------------------
40 constant WEATHER_BAR_WIDTH
: scale-xPr ( xPr -- scaled-xPr )
>r WEATHER_BAR_WIDTH 100 r> scaling ;
: scaled-forecast ( rPr sPr -- scaled-rPr scaled-sPr )
>r scale-xPr r> scale-xPr ;
: .forecast-in-bar ( rPr sPr -- )
scaled-forecast
WEATHER_BAR_WIDTH get-rPr/cPr/sPr ( scaled-rPr scaled-cPr scaled-sPr )
cr 18 spaces [char] O .nchars [char] ^ .nchars [char] X .nchars ;
: .forecast-in-percent ( rPr sPr -- )
100 get-rPr/cPr/sPr ( rPr cPr sPr )
cr ." Tomorrow weather: "
." Sunny " 2 u.r
." % , Cloudy " 2 u.r
." % , Rainy " 2 u.r
." %" ;
: .forecast ( rPr sPr -- )
2dup .forecast-in-percent .forecast-in-bar ;
: get-weather-forecast' ( -- rPr sPr )
\ make Probabilities for Rainy, Sunny (that for Cloudy is implicit)
rand100 rand100 2>r
2r@ min \ rPr : (min pr1 pr2)
100 2r> max - \ sPr : (- 100 (max pr1 pr2))
;
: get-weather-forecast ( -- rPr sPr )
get-weather-forecast' 2dup .forecast ;
\ -------------------------------------------------------------------
30 constant CASH_BAR_WIDTH
: scale-cash ( cash -- scaled-cash )
>r CASH_BAR_WIDTH $SAVINGS_TARGET r> scaling ;
: scaled-nocash/cash ( cash -- scaled-nocash scaled-cash )
scale-cash >r CASH_BAR_WIDTH r@ - r> ;
: .cash-bar ( cash -- )
\ without the clipping, either of scaled amounts might be minus,
\ which will be intepreted as a huge unsigned number by .nchars.
clip-cash-range
\ output '#' CASH-BAR and '-' NOCASH-BAR
scaled-nocash/cash
[char] # .nchars [char] - .nchars ;
: .cash ( cash name-cs -- ) \ printf(" %s : %d-yen", name, cash)
2 spaces count type ." : " 5 .r ." -yen " ;
: .wallet ( cash name-cs -- )
over >r .cash r> .cash-bar ;
: .wallets ( man-cash com-cash -- )
swap
cr ." wallets: "
cr c" man" .wallet
cr c" com" .wallet
cr
;
\ -------------------------------------------------------------------
: get-man-plan ( _rPr _sPr cash -- _rPr _sPr man's-plan )
max-tofus-to-make >r
c" How many tofus will you make?" 1 r> get-int-within-range ;
: .com-plan ( com-plan -- )
cr ." Computer will make " . space ." tofus." ;
\ FIXME: introducing Bayesian estimation or such things someday :)
: get-com-plan' ( rPr sPr -- com-plan )
locals| sPr rPr |
50 sPr <= if 500 exit then
30 rPr < if 100 exit then
300
;
: get-com-plan ( rPr sPr cash -- rPr sPr com-plan )
max-tofus-to-make >r 2dup get-com-plan' r> min
dup .com-plan
;
\ -------------------------------------------------------------------
variable 'day
: update-cash ( sales-limit stock cash -- cash' )
>r calculate-profit r> + ;
: sell-tofus-for-one-day ( man com -- man' com' )
locals| com man |
get-weather-forecast ( rPr sPr )
man get-man-plan >r ( rPr sPr ; r: man-stock )
com get-com-plan >r ( rPr sPr ; r: man-stock com-stock )
cr cr ." * * * * * * Day " 'day @ 2 u.r ." * * * * * *"
get-next-weather ( weather ; r: man-stock com-stock )
weather->sales dup ( limit limit ; r: man-stock com-stock )
r> com update-cash swap ( com' limit ; r: man-stock )
r> man update-cash swap ( man' com' )
;
: both-continue? ( cash1 cash2 -- cash1 cash2 bool )
2dup continue-game? swap continue-game? and ;
: game-loop ( man-cash com-cash -- man-cash' com-cash' )
randomize
1 'day !
begin
2dup .wallets
both-continue? while
sell-tofus-for-one-day
1 'day +!
repeat ;
: compare-cash ( man-cash com-cash -- ordering )
\ clip args, since it's a draw when both go bankrupt or when both goal
>r clip-cash-range r> clip-cash-range compare-int ;
: play-one-game ( -- ordering )
$INITIAL_CASH $INITIAL_CASH game-loop
compare-cash ;
: main ( -- )
show-credit
s" Do you want TheMatrix display mode?" y-or-n-p 'slow-tty? !
s" Do you want to read the rule of the game?" y-or-n-p if show-goal then
begin
play-one-game case
LT of cr ." Computer win!" endof
EQ of cr ." It is a draw." endof
GT of cr ." You win!" endof
abort" main"
endcase
s" Play another game?" yes-or-no-p while
repeat ;
\ This file is meant to be used with tofu.fth, so see the heading comment in it.
\ Quasi general words spinned off from tofu.fth
\ ToDo
\ - introduce 64-bit XorShift PRNG into lib.fth
ANEW --TOFU_LIB--
\ export the following words to tofu.fth
\ 3dup ( x y z -- x y z )
\ 3drop ( x y z -- )
\ yes-or-no-p ( ca u -- f )
\ y-or-n-p ( ca u -- f )
\ enum ( "w" -- )
\ scaling ( scaled-all all n -- scaled-n )
\ clip-int ( min max i1 -- i2 )
\ enum Ordering { LT EQ GT }
\ compare-int ( a b -- ordering )
\ get-int-within-range ( prompt-cs min max -- n )
\ randomize ( -- )
\ rand100 ( -- 0..100 )
\ s" compat/assert.fs" included
\ 0 assert-level !
\ ===================================================================
\ general utilities
: not ( x -- flag ) s" 0= " evaluate ; immediate
\ : -rot ( x y z -- z x y ) rot rot ;
: 3dup ( x y z -- x y z x y z ) 2 pick 2 pick 2 pick ;
: 3drop ( x y z -- ) 2drop drop ;
: word-bits ( -- +n ) 1 cells 8 * ;
\ already in gforth
\ : under+ ( a b c -- a+c b ) rot + swap ;
\ : on ( adr -- ) true swap ! ;
\ : off ( adr -- ) false swap ! ;
\ : bounds ( adr cnt -- adr+cnt adr ) over + swap ;
: swap- swap - ;
\ from ThinkingForth
: direction ( -n|0|+n -- -1|0|+1 ) dup if 0< 1 or then ;
\ ===================================================================
\ enum
: ++ ( addr -- ) 1 swap +! ;
: enum-from ( n <word> -- ) create , does> dup @ constant ++ ;
: enum ( <word> -- ) 0 enum-from ;
\ ===================================================================
\ integer operations
: scaling ( scaled-all all n -- scaled-n )
-rot */ ;
: clip-int ( min max i1 -- i2 )
min max ;
-1 enum-from Ordering
Ordering LT \ -1
Ordering EQ \ 0
Ordering GT \ +1
: compare-int ( i1 i2 -- ordering ) - direction ;
\ ===================================================================
\ yes-or-no-p, y-or-n-p
: clear-input begin key? while key drop repeat ;
: compare-cs ( ca u cs -- f ) count compare ;
: x-or-y-prompt ( cs-x cs-y ca u -- ) \ printf("\n%s (%s or %s) ", s, x, y)
cr type
2>r c" ) " r> c" or " r> c" ("
5 0 do count type loop ;
: 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 x-or-y-prompt
pad dup 10 accept \ note: gforth's ACCEPT echo-backs input
( ca' u' -- ) \ an accepted string is on the stack
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 ;
\ ===================================================================
\ Input utilities
: get-int ( -- n )
0. \ push UD ZERO onto stack
pad dup 6 accept \ ( 0. ca1 u1 )
>number \ ( ud2 ca2 u2 )
2drop d>s ;
: prompt-range ( cs min max --) \ printf("\n%s ( %d -- %d ) ", s, min, max)
rot count cr type swap
space [char] ( emit space . s" -- " type . [char] ) emit space ;
: get-int-within-range ( cs min max -- n )
0 begin
drop 3dup prompt-range \ ( cs min max )
get-int \ ( cs min max n )
3dup -rot 1+ \ ( cs min max n min limit )
within \ ( cs min max bool )
until >r 3drop r> ; \ leave only bool
\ ===================================================================
\ slow-tty-mode
\ variable 'ms-count
\ 7 'ms-count !
\ : pauses ( u -- ) ?dup if 'ms-count @ * ms else drop then ;
\ : 1pause 1 pauses ;
\ \ slow-tty-mode
\ variable 'slow-tty?
\ 'slow-tty? off
\ : emit' ( x -- ) 'slow-tty? @ if 1pause then emit ;
\ : type' ( ca u -- ) ?dup if bounds do i c@ emit' loop else drop then ;
\ : type' ( ca u -- ) 0 ?do dup i + c@ emit' loop drop ;
\ \ gforth dependent
\ :noname '"' parse type' ;
\ :noname '"' parse postpone sliteral postpone type' ;
\ interpret/compile: ."
\ ===================================================================
\ PRNG
enum PrngType
\ PrngType PRNG_SIMPLE_LINEAR_CONGRUENTIAL
PrngType PRNG_GFORTH_BUILTIN
PrngType PRNG_C_G_MONTGOMERY
PrngType PRNG_XOR_SHIFT
\ choose one of aboves
\ PRNG_GFORTH_BUILTIN constant PRNG
PRNG_C_G_MONTGOMERY constant PRNG
\ PRNG_XOR_SHIFT constant PRNG
\ -------------------------------------------------------------------
PRNG PRNG_GFORTH_BUILTIN = [IF]
require random.fs
: randomize ( -- ) \ assuming CELL returns 8 (see random.fs)
time&date 2drop ( sec min hr day )
+ + + 0 ?do rnd drop loop
rnd seed ! ;
\ random ( n -- 0..n-1 )
[THEN]
\ -------------------------------------------------------------------
PRNG PRNG_C_G_MONTGOMERY = [IF]
\ From https://groups.google.com/forum/#!topic/comp.lang.forth/DglVTqncYzQ
\ See also https://groups.google.com/forum/#!topic/comp.lang.forth/4hOqv2m8wA4
\ especially, 2011-12-14(Hans Bezemer) and 2011-12-15(Brad Eckert)
1 cells 2 = [IF]
26088 ( 65E8 ) constant RMULT
[ELSE]
2051013963 ( 7A3FFD4B ) constant RMULT
[THEN]
2variable *rloc* 3 1 *rloc* 2!
: rnd ( -- u ) *rloc* 2@ RMULT um* rot 0 d+ over *rloc* 2! ;
: randomize ( -- ) \ reseed randomly by exerciseing rnd a few times
time&date 2drop ( sec min hr day )
+ + + 0 ?do rnd drop loop
rnd rnd *rloc* 2! ;
: random ( n -- 0..n-1 ) rnd um* nip ;
[THEN]
\ -------------------------------------------------------------------
PRNG PRNG_XOR_SHIFT = [IF]
\ FIXME
[THEN]
\ -------------------------------------------------------------------
\ And common utility PRNG words
: rand100 ( -- 0..100 )
101 random ;
\ in gforth, the definition of include is as follows
\ : include ( "name" -- ) bl-word count included ;
\ and the following lines are definitely portable.
s" anew.fth" included
s" editor.fth" included
\ from Wil Baden's "ToolBelt 2002"
: possibly ( "name" -- ) bl word find ?dup and if execute then ;
: anew ( "name" -- ) >in @ possibly >in ! marker ;
\ typical usage:
\ - put the following two lines in a editor target file, say "xxx.fth"
\ : this-file s" xxx.fth" ; \ "this-file" can be any other name
\ ' this-file is editor target
\ - execute the word EDITOR after loading xxx.fth
defer editor-target ( -- c-addr u )
: set-editor-target ( xt -- ) is editor-target ;
: cpstr ( to fr u -- to+u ) >r swap r> 2dup + >r cmove r> ;
: edcmd0 s" vim -S ~/home/vim/forth.vim " ;
: edcmd pad dup edcmd0 cpstr editor-target cpstr pad - ;
: ZZ editor-target included ; \ load editor target
: editor edcmd system ZZ ; \ do ZZ after quiting the editor
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.