phorth---（その1.5）算術・スタックオペレータの追加
算術オペレータの追加
普通に使われる演算で以下のものを追加します．PostScript Level 1のサブセットです．
- add : n1 n2 add => n1+n2
- sub : n1 n2 sub => n1-n2
- mul : n1 n2 mul => n1 x n2
- idiv : n1 n2 idiv => d
- mod : n1 n2 mod => r (n1 = n2 x d +r (0<=r<|d|)
- abs : n1 abs |n1|（絶対値）
- neg : n1 neg -> -n1
微妙な「負の数」が存在するときの余りや商は数学的な定義にそろえます．
3 4 mod => 3=4*0+3
辞書にある「ユーザ定義オペレータ」の探索は一番最後に移動させなければいけません．また，この期に及んで，今までのパーサは負の数を読み込めないという間抜けな不具合があったので，パーサも修正します．
-- パーサの修正 literal::Parser Exp literal = do sign <- option ' ' (char '-') num <- (many1 digit) return (Push (read $ sign:num)) -- procExpの処理の追加 procExp i@Interp {stack=(Pushed x1):(Pushed x2):xs} (Invoke "add") = return i{stack=(Pushed $ x1+x2):xs} procExp i@Interp {stack=(Pushed x1):(Pushed x2):xs} (Invoke "sub") = return i{stack=(Pushed $ x2-x1):xs} procExp i@Interp {stack=(Pushed x1):(Pushed x2):xs} (Invoke "mul") = return i{stack=(Pushed $ x1*x2):xs} procExp i@Interp {stack=(Pushed x1):(Pushed x2):xs} (Invoke "mod") = return i{stack=(Pushed $ abs(x2) `mod` abs(x1)):xs} procExp i@Interp {stack=(Pushed x1):(Pushed x2):xs} (Invoke "idiv") = return i {stack=(Pushed $ signum(x1)*signum(x2) *(abs(x2) `div` abs(x1))):xs} procExp i@Interp {stack=(Pushed x):xs} (Invoke "abs") = return i{stack=(Pushed $ abs x):xs} procExp i@Interp {stack=(Pushed x):xs} (Invoke "neg") = return i{stack=(Pushed $ (-1)*x):xs} procExp i@Interp{dict=dict} (Invoke name) = interp i (dict Map.! name)
スタックオペレータの追加
わざわざInterpをIO Interpにしているのは，現在のスタックの状況を出力するオペレータを作るためだったのですがのびのびになっています．何はともあれ，スタックオペレータも基本的なものを少し．
- dup : s dup => s s
- exch : a b exch => b a
- clear : a1 a2 ... an clear => --
- copy : a1 a2 ... an n copy a1 a2 ... an a1 a2 ... an
- index : an an-1 ... a0 n index an an-1 ... a0 an
- count : a1 a2 ... an count a1 a2 ... an n （スタックの要素数を数える）
- roll : an an-1 ... a1 n k => ak an a1 .. an-k (n個の要素をk個上に動かす)
- == : a == -> -- （出力：スタックは空に）
- pstack : a1 a2 ... an pstack => a1 a2 ... an （スタックの全内容を出力：スタックはそのまま）
これらのうちrollがわかりにくいですので後回しにします．
procExp i@Interp {stack=x:xs} (Invoke "dup") = return i{stack=x:x:xs} procExp i@Interp {stack=x1:x2:xs} (Invoke "exch") = return i{stack=x2:x1:xs} procExp i (Invoke "clear") = return i{stack=[]} procExp i@Interp {stack=(Pushed n):xs} (Invoke "copy") = return i{stack=(take (fromInteger n) xs)++xs} procExp i@Interp {stack=xs} (Invoke "count") = return i{stack=(Pushed $ toInteger $ length xs)++xs} procExp i@Interp {stack=xs} (Invoke "==") = mapM_ print xs >> return i{stack=[]} procExp i@Interp {stack=xs} (Invoke "pstack") = mapM_ print xs >> return i
整理
15個（rollをいれて16個，他のもいれると20個）ほどのオペレータを定義しましたが，同じようなことを延々と繰り返してるのでもう少し抽象化してみます．
そのためにまず，StackbaleをNumクラスとIntegralクラスのインスタンスにしてしまいます．Numクラスは加減乗算・絶対値・符号のために，Integralクラスは割算・剰余のためにです．
NumクラスのインスタンスにするためにEqクラスのインスタンスにします．IntegaralクラスのインスタンスにするためにStackableをEnumクラスとRealクラスのインスタンスにもします．さらに，RealクラスのためにStackabelをOrdクラスのインスタンスにします．
そして，Stackable型のShowクラスのインスタンスにするのをderivingではなく，自前でshowを定めてIOの出力形式を簡略化します．
type AST = [Exp] data Exp = Push Literal | Invoke Word | Name Word | Block AST deriving (Show, Eq) -- Eqクラスのインスタンスにする type Stack = [Stackable] data Stackable = Pushed Literal | Opname Word | Code AST deriving Eq -- 計算できるところだけ．他はエラーを期待して放置 instance Num Stackable where (+) (Pushed a) (Pushed b) = Pushed (a+b) (*) (Pushed a) (Pushed b) = Pushed (a*b) abs (Pushed a) = Pushed $ abs a signum (Pushed a) = Pushed $ signum a fromInteger a = Pushed a negate (Pushed a) = Pushed $ negate a instance Integral Stackable where quotRem (Pushed a) (Pushed b) = (Pushed $ quot a b, Pushed $ rem a b) toInteger (Pushed a) = a instance Enum Stackable where succ (Pushed a) = Pushed $ succ a pred (Pushed a) = Pushed $ pred a toEnum a = Pushed $ toInteger a fromEnum (Pushed a) = fromInteger a enumFrom (Pushed a) = map Pushed $ enumFrom a enumFromThen (Pushed a) (Pushed b) = map Pushed $ enumFromThen a b enumFromTo (Pushed a) (Pushed b) = map Pushed $ enumFromTo a b enumFromThenTo (Pushed a) (Pushed b) (Pushed c) = map Pushed $ enumFromThenTo a b c instance Real Stackable where toRational (Pushed a) = toRational a instance Ord Stackable where compare (Pushed a) (Pushed b) = compare a b instance Show Stackable where show (Pushed a) = show a show (Opname a) = "Opname " ++ show a show (Code a) = "Code " ++ show a
Stackable型をNumクラスのインスタンスにする部分は，計算できるPushed Integerの部分だけ定めてあとは放置することでエラーを期待します．Showクラスのインスタンスにする部分はStackableの各データコンストラクタの引数の型がまたShowクラスのインスタンスであることを使って定めました．
こうしておくと算術演算系のオペレータがすっきりします．まず，
procStack::Interp->(Stack->Stack)->IO Interp procStack i f = return i{stack = f $ stack $ i}
なる関数を定めておきます．これはStackを変形する関数を与えることでインタープリータを更新します．これを用いることで，次のように整理できます．
procExp i (Invoke "add") = procStack i (\(x1:x2:xs) -> (x1+x2):xs) procExp i (Invoke "sub") = procStack i (\(x1:x2:xs) -> (x1-x2):xs) procExp i (Invoke "mul") = procStack i (\(x1:x2:xs) -> (x1*x2):xs) procExp i (Invoke "mod") = procStack i (\(x1:x2:xs) -> ((abs x2) `mod` (abs x1)):xs) procExp i (Invoke "idiv") = procStack i (\(x1:x2:xs) -> (signum x1)*(signum x2) *((abs x2) `div` (abs x1)):xs) procExp i (Invoke "abs") = procStack i (\(x:xs) -> (abs x):xs) procExp i (Invoke "neg") = procStack i (\(x:xs) -> (negate x):xs)
またASTからスタックそのものを構築するいくつかの処理も同様に整理します．オペレータdef，==，pstackはスタック以外の処理があるのでそのままです．オペレータcopyだけちょっと気に入らない，スタック（リスト）処理関数の中にデータコンストラクタがありますますが，放置します．
procExp i (Push lit) = procStack i $(:) (Pushed lit) procExp i (Name name) = procStack i $(:) (Opname name) procExp i (Block ast) = procStack i $(:) (Code ast) procExp i (Invoke "pop") = procStack i $ drop 1 procExp i (Invoke "dup") = procStack i (\ (x:xs)->(x:x:xs)) procExp i (Invoke "exch") = procStack i (\ (x1:x2:xs)-> (x2:x1:xs)) procExp i (Invoke "clear") = procStack i (\ _ -> []) procExp i (Invoke "copy") = procStack i (\ ((Pushed n):xs) -> (take (fromInteger n) xs)++xs ) procExp i (Invoke "count") = procStack i (\xs ->(Pushed $ toInteger $ length xs):xs ) procExp i@Interp {stack=xs} (Invoke "==") = mapM_ print xs >> return i{stack=[]} procExp i@Interp {stack=xs} (Invoke "pstack") = mapM_ print xs >> return i procExp i@Interp {stack=(Code code):(Opname name):xs, dict = dict} (Invoke "def") = return i{stack=xs,dict = Map.insert name code dict }
だいぶすっきりというか隠蔽できたようです．まだ気になるのはInterp型のiがしつこくついて回っていることです．こういうのも隠蔽すべきですがそれも先送りします（Stateモナドによるメモ化の形に似てますし（状態を引数として持ちまわす）ので，harrorthでReaderモナドを使って理由もこれで見えてきます）．
