モノイドスタックマシン







少し前に、コンパイラとスタックマシンに関する優れた刺激的な記事がHabréに掲載されました。 バイトコードエグゼキュータの単純な実装から、より効率的なバージョンへの道を示しています。 スタックドマシンの開発例で、これをHaskell-wayでどのように行うことができるかを示したかったのです。







スタックマシンの言語解釈を例として使用して、半群とモノイドの数学的概念がプログラムアーキテクチャの開発と拡張に役立つ方法、モノイド代数の使用方法、および代数システム間の準同型の形式でプログラムを構築する方法について説明します。 実用的な例として、最初にEDSLの形式のコードから分離できないインタープリターを構築し、それからさまざまなことを教えます:任意のデバッグ情報を記録し、プログラムコードをプログラム自体から分離し、簡単な静的分析を行い、さまざまな効果で計算します。







この記事は、Haskell言語を中級以上のレベルで話す人、すでに仕事や研究でそれを使用している人、そしてまだ役職人が何をしていないかを見て一目見たすべての好奇心の強い人を対象としています。 もちろん、前の段落で怖がらなかった人たちにとっては。







コードに多くの例があり、多くの資料が見つかりました。読者がその中に飛び込む必要があるかどうかを理解しやすくするために、注釈付きのコンテンツを提供します。







記事の内容


翻訳および解釈タスクは、プログラミングの最も多様な側面を示すために、多くの興味深い有用な例を提供します。 非常に実用的でありながら、さまざまなレベルの複雑さと抽象化を行うことができます。 この記事では、 セミグループモノイドという2つの重要な数学的構造の機能を実証することに焦点を当てます。 モナドやレンズほど頻繁には議論されておらず、小さなプログラマーを怖がらせることはありません。これらの構造ははるかに理解しやすいですが、それでも関数プログラミングの根底にあります。 専門家によって実証されているモノイドの巧妙な習熟は、ソリューションのシンプルさとエレガントさを賞賛します。







Habréの記事で「モノイド」という単語を検索すると、4ダース以下の記事が発行されます(たとえば、同じモナドについては300件あります)。 それらはすべて概念的に次のようなものから始まります: モノイドは非常に多く...そして、非常に理解しやすい熱意で、彼らはモノイドが何であるかをリストします-線から指の木まで、正規表現パーサーから神は他のものを知っています ! しかし実際には、逆の順序で考えます:モデル化する必要があるオブジェクトがあり、そのプロパティを分析して、1つまたは別の抽象的な構造の兆候があることを見つけ、決定します:この状況から結果が必要なのか、それをどのように使用するのか。 このようにします。 同時に、有用なモノイドのコレクションにいくつかの興味深い例を追加します。









スタックマシンの言語とプログラム



スタックマシンは、関数型プログラミングを勉強するとき、通常、畳み込みの概念に近づくときに現れます。 この場合、最も単純なスタック計算機のエグゼキューターの非常に簡潔な実装が、たとえば次のように与えられます:







最も単純なスタック計算機
calc :: String -> [Int] calc = interpretor . lexer where lexer = words interpretor = foldl (flip interprete) [] interprete c = case c of "add" -> binary $ \(x:y:s) -> x + y:s "mul" -> binary $ \(x:y:s) -> x * y:s "sub" -> binary $ \(x:y:s) -> y - x:s "div" -> binary $ \(x:y:s) -> y `div` x:s "pop" -> unary $ \(x:s) -> s "dup" -> unary $ \(x:s) -> x:x:s x -> case readMaybe x of Just n -> \s -> n:s Nothing -> error $ "Error: unknown command " ++ c where unary fs = case s of x:_ -> fs _ -> error $ "Error: " ++ c ++ " expected an argument." binary fs = case s of x:y:_ -> fs _ -> error $ "Error: " ++ c ++ " expected two arguments."
      
      





Text.Read



モジュールの合計readMaybe



パーサーを使用します。 プログラムを最大2倍に短縮することは可能ですが、有益なエラーメッセージが表示されないため、見苦しくなります。







会話を始めましょう! その後、原則として、それらはエフェクトにfoldM



始めます: foldM



畳み込みをfoldM



に変更し、 foldM



Either String



モナドを介して全体を提供し、ロギングを追加し、すべてをWriterT



トランスフォーマーでラップし、変数のStateT



辞書を実装します。 時々、単項計算のクールさを示すために、式のすべての可能な値を返す曖昧な計算機を実装します 2 p m 3 4 p m 8 p m 5     。 これは長くて、楽しくて面白い会話です。 ただし、同じ結果で終わりますが、すぐに別の方法でストーリーをリードします。







なぜ、一般に、それは折り畳みについてですか? 畳み込み(カタモフィズム)は帰納的データの順次処理の抽象化であるためです。 スタックマシンはコードを直線的に実行し、一連の命令を実行して、1つの値(スタックの状態)を生成します。 生細胞のマトリックスRNAを翻訳する畳み込みスタックマシンの仕事を想像するのが好きです。 リボソームは、RNAチェーン全体を段階的に通過し、ヌクレオチドトリプレットをアミノ酸と比較して、タンパク質の一次構造を作成します







畳み込みマシンにはいくつかの制限があります。主なことは、プログラムは常に最初から最後まで一度だけ読み取られるということです。 分岐、ループ、およびサブルーチン呼び出しでは、インタープリターの概念を変更する必要があります。 もちろん複雑なことは何もありませんが、そのようなマシンは単純な畳み込みではもはや記述できません。







言語相対性の仮説によれば、私たちが使用する言語の特性は、思考の特性に直接影響します。 マシンではなく、それが制御されている言語プログラムに注意しましょう。







比較的低レベル(JavaとPythonまたは.NET仮想マシンのバイトコード)と高レベルの言語(PostScript、ForthまたはJoy)の両方のすべてのスタック指向言語には、1つの基本的な共通の特性があります。正しいプログラムを入手してください。 確かに、正しいとは「正しい」という意味ではありません。このプログラムはあらゆるデータでエラーが発生したり、無限のサイクルで失敗したり、まったく意味をなさない場合があります。 同時に、正しいプログラムをパーツに分割することで、正確であるため、これらのパーツを簡単に再利用できます。 最後に、どのスタック言語でも、外部メモリを使用せずに、マシンの内部状態(スタックまたはレジスタ)でのみ動作するコマンドのサブセットを選択できます。 このサブセットは、 連結のプロパティを持つ言語を形成します。 このような言語では、どのプログラムもマシン状態コンバーターの意味を持ち、プログラムの順次実行はその構成と同等です。つまり、状態コンバーターでもあります。







一般的なパターンが見られます。正しいプログラムの組み合わせ(連結)が正しいプログラムを生成し、コンバーターの組み合わせがコンバーターを生成します。 スタック言語プログラムは、連結操作に関して閉じられているか、 groupoidまたはmagmaと呼ばれる構造を形成していることがわかります。 つまり、プログラムをテープに書き込むことで、ほぼランダムにカットして、受信したセグメントから新しいプログラムを作成できます。 さらに、単一の命令でセグメントに分割できます。







結合するとき、順序は重要です。 たとえば、これらの2つのプログラムは間違いなく異なります。









 t e x t t t 5 d u p p o p n e q t e x t t t 5 p o p d u p   







ただし、プログラムをどこでカットするかは関係ありません。すぐにこの場所に貼り付けてください。





 texttt5dup+ textttpop= texttt5+ textttduppop







この単純な事実は、連結操作結合性を反映しており、スタックプログラムが新しいレベルに形成する構造を取ります。これはセミグループであることを理解しています。

そして、これはプログラマとして私たちに何を与えますか? 結合性により、このための任意の適切なプログラムセクションのプリコンパイル、最適化、さらには並列化が可能になり、それらを同等のプログラムに結合できます。 ブラケットを配置する場所を気にしないので、プログラムの任意のセグメントの静的分析を実行し、プログラム全体の分析でそれを使用する余裕があります。 これらは、人ではなく翻訳者が書く低レベル言語または中間言語にとって非常に重要かつ深刻な機会です。 そして、数学者と熟練した機能的労働者の観点から、これは機械状態変換プログラムを本格的な準同型にします。 自己準同型はまた、合成操作で半群を形成します。 代数では、そのような内部準同型は、ある集合に関して変換半群と呼ばれます。 たとえば、有限オートマトンは、多くの状態の半グループの変換を形成します。







「セミグループ」は中途半端で、どういうわけか劣っています。 たぶんスタックプログラムはグループを形成しますか? ええと...いいえ、ほとんどのプログラムは元に戻せません。つまり、実行結果に応じて、元のデータを明確に復元することはできません。 しかし、中立的な要素があります。 アセンブリ言語では、  textttnop そして何もしません。 そのような演算子がスタック言語で明示的に定義されていない場合、次のようにいくつかのコマンドを組み合わせることで簡単に取得できます。  textttincdec textttduppop または  texttt 。 そのようなペアは、プログラムから簡単に切り取ることができ、逆に、任意の量の任意の場所に貼り付けることができます。 ユニットがあるので、プログラムはユニットまたはモノイドで セミグループを形成します。 したがって、それらをモノイドの形でプログラム的に実装することができます-積み重ねられたマシンの状態に対する内部準同型。 これにより、マシンの基本的な操作の小さなセットを定義し、その構成を使用してプログラムを作成し、組み込みドメイン固有言語(EDSL)の形式でスタック言語を取得できます。







Haskellでは、セミグループとモノイドは、セミグループとMonoid



を使用して記述されMonoid



。 それらの定義は単純で、基本構造のみを反映しています。結合性と中立性の要件は、プログラマーが確認する必要があります。







 class Semigroup a where (<>) :: a -> a -> a class Semigroup a => Monoid a where mempty :: a
      
      







車を作る



プログラムの見出し
 {-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving #-} import Data.Semigroup (Max(..),stimes) import Data.Monoid import Data.Vector ((//),(!),Vector) import qualified Data.Vector as V (replicate)
      
      





すぐにスタックと有限のメモリを備えたマシンを構築し、適切でクリーンな方法でクラッシュする可能性があります。 これはすべて、モナドを使用せずに実装され、必要なデータをマシンを記述する型にカプセル化します。 したがって、すべての基本プログラム、したがってすべての組み合わせは、その状態の純粋なコンバーターになります。







まず、仮想マシンのタイプと簡単なセッター関数を定義することから始めましょう。







 type Stack = [Int] type Memory = Vector Int type Processor = VM -> VM memSize = 4 data VM = VM { stack :: Stack , status :: Maybe String , memory :: Memory } deriving Show emptyVM = VM mempty mempty (V.replicate memSize 0) setStack :: Stack -> Processor setStack x (VM _ sm) = VM xsm setStatus :: Maybe String -> Processor setStatus x (VM s _ m) = VM sxm setMemory :: Memory -> Processor setMemory x (VM s st _) = VM s st x
      
      





プログラムのセマンティクスを明示的にするには、セッターが必要です。 プロセッサー(タイプProcessor



)とは、コンバーターVM -> VM



を意味しVM -> VM









次に、変換モノイドおよびプログラムのラッパータイプを定義します。







 newtype Action a = Action { runAction :: a -> a } instance Semigroup (Action a) where Action f <> Action g = Action (g . f) instance Monoid (Action a) where mempty = Action id newtype Program = Program { getProgram :: Action VM } deriving (Semigroup, Monoid)
      
      





ラッパーのタイプは、プログラムを結合する原理を決定します。これらは、構成の逆順(左から右)の準同型です。 ラッパーを使用すると、コンパイラは、 Program



タイプがSemigroup



Monoid



Monoid



要件をどのように実装するかを独立して決定できMonoid









プログラムエグゼキューターは簡単です:







 run :: Program -> Processor run = runAction . getProgram exec :: Program -> VM exec prog = run prog emptyVM
      
      





エラーメッセージは、 err



関数によって生成されます。







 err :: String -> Processor err = setStatus . Just $ "Error! " ++ m
      
      





通常使用されるのではなく、 Maybe



タイプを使用します。ステータスの空のNothing



値は、危険なことは何も起きていないことを意味し、文字列値は問題を示しています。 便宜上、2つのスマートコンストラクターを定義します。1つはスタックでのみ動作するプログラム用、もう1つはメモリが必要なプログラム用です。







 program :: (Stack -> Processor) -> Program program f = Program . Action $ \vm -> case status vm of Nothing -> f (stack vm) vm _ -> vm programM :: ((Memory, Stack) -> Processor) -> Program programM f = Program . Action $ \vm -> case status vm of Nothing -> f (memory vm, stack vm) vm _ -> vm
      
      





これで、スタックとメモリ、整数演算、および等価関係と順序関係を操作するための基本的な言語コマンドを定義できます。







スタックを操作する
 pop = program $ \case x:s -> setStack s _ -> err "pop expected an argument." push x = program $ \s -> setStack (x:s) dup = program $ \case x:s -> setStack (x:x:s) _ -> err "dup expected an argument." swap = program $ \case x:y:s -> setStack (y:x:s) _ -> err "swap expected two arguments." exch = program $ \case x:y:s -> setStack (y:x:y:s) _ -> err "exch expected two arguments."
      
      





メモリを操作する
 --       indexed if = programM $ if (i < 0 || i >= memSize) then const $ err $ "expected index in within 0 and " ++ show memSize else f put i = indexed i $ \case (m, x:s) -> setStack s . setMemory (m // [(i,x)]) _ -> err "put expected an argument" get i = indexed i $ \(m, s) -> setStack ((m ! i) : s)
      
      





算術演算と関係
 unary nf = program $ \case x:s -> setStack (fx:s) _ -> err $ "operation " ++ show n ++ " expected an argument" binary nf = program $ \case x:y:s -> setStack (fxy:s) _ -> err $ "operation " ++ show n ++ " expected two arguments" add = binary "add" (+) sub = binary "sub" (flip (-)) mul = binary "mul" (*) frac = binary "frac" (flip div) modulo = binary "modulo" (flip mod) neg = unary "neg" (\x -> -x) inc = unary "inc" (\x -> x+1) dec = unary "dec" (\x -> x-1) eq = binary "eq" (\x -> \y -> if (x == y) then 1 else 0) neq = binary "neq" (\x -> \y -> if (x /= y) then 1 else 0) lt = binary "lt" (\x -> \y -> if (x > y) then 1 else 0) gt = binary "gt" (\x -> \y -> if (x < y) then 1 else 0)
      
      





本格的な作業には、分岐とループだけでは不十分です。 実際、組み込み言語の場合、分岐だけで十分です。ホスト言語(Haskell)で再帰を使用してループを編成できますが、言語を自給自足にします。 さらに、プログラムがセミグループを形成するという事実を利用して、指定された回数のプログラムの繰り返しの組み合わせを決定します。 彼はスタックから繰り返し回数を取得します。







分岐とループ
 branch :: Program -> Program -> Program branch br1 br2 = program go where go (x:s) = proceed (if (x /= 0) then br1 else br2) s go _ = err "branch expected an argument." while :: Program -> Program -> Program while test body = program (const go) where go vm = let res = proceed test (stack vm) vm in case (stack res) of 0:s -> proceed mempty s res _:s -> go $ proceed body s res _ -> err "while expected an argument." vm rep :: Program -> Program rep body = program go where go (n:s) = proceed (stimes n body) s go _ = err "rep expected an argument." proceed :: Program -> Stack -> Processor proceed prog s = run prog . setStack s
      
      





branch



while



関数のタイプは、これらがスタンドアロンプ​​ログラムではなく、プログラムコンビネーターであることを示しています。HaskellでEDSLを作成する際の典型的なアプローチです。 stimes



関数stimes



すべてのセミグループに対して定義され、指定された数の要素の構成を返します。







最後に、実験用のプログラムをいくつか作成します。







プログラム例
 --   fact = dup <> push 2 <> lt <> branch (push 1) (dup <> dec <> fact) <> mul --   fact1 = push 1 <> swap <> while (dup <> push 1 <> gt) ( swap <> exch <> mul <> swap <> dec ) <> pop --     --    range = exch <> sub <> rep (dup <> inc) --    , --      fact2 = mconcat [ dec, push 2, swap, range, push 3, sub, rep mul] --      fact3 = dup <> put 0 <> dup <> dec <> rep (dec <> dup <> get 0 <> mul <> put 0) <> get 0 <> swap <> pop --      copy2 = exch <> exch --     --     gcd1 = while (copy2 <> neq) ( copy2 <> lt <> branch mempty (swap) <> exch <> sub ) <> pop --       pow = swap <> put 0 <> push 1 <> put 1 <> while (dup <> push 0 <> gt) ( dup <> push 2 <> modulo <> branch (dec <> get 0 <> dup <> get 1 <> mul <> put 1) (get 0) <> dup <> mul <> put 0 <> push 2 <> frac ) <> pop <> get 1
      
      





3つのコンビネータを備えた18のコマンドで動作するマシンを定義するコメントとタイプアノテーションを含む120行のコードが判明しました。 これが私たちの車の仕組みです。







 λ> exec (push 6 <> fact) VM {stack = [720], status = Nothing, memory = [0,0,0,0]} λ> exec (push 6 <> fact3) VM {stack = [720], status = Nothing, memory = [720,0,0,0]} λ> exec (push 2 <> push 6 <> range) VM {stack = [6,5,4,3,2], status = Nothing, memory = [0,0,0,0]} λ> exec (push 6 <> push 9 <> gcd1) VM {stack = [3], status = Nothing, memory = [0,0,0,0]} λ> exec (push 3 <> push 15 <> pow) VM {stack = [14348907], status = Nothing, memory = [43046721,14348907,0,0]} λ> exec (push 9 <> add) VM {stack = [9], status = Just "Error! add expected two arguments", memory = [0,0,0,0]}
      
      





実際、私たちは新しいことを何もしませんでした-内相変換コンバーターを組み合わせることで、本質的に畳み込みに戻りましたが、暗黙的になりました。 畳み込みは帰納的データの順次処理の抽象化を提供することを思い出してください。 私たちの場合、データはオペレーターがプログラムを接着すると誘導的に生成されます \ダ 、そして、それらは、初期状態に適用されるまで、機械変換機能の構成のチェーンの形で、自己変形に「格納」されます。 コンビネータのbranch



while



チェーンはツリーまたはループに変わり始めます。 一般的なケースでは、ストアメモリを備えたオートマトン、つまりスタックマシンの操作を反映したグラフを取得します。 プログラムを実行するときに「崩壊」するのはこの構造です。







この実装はどの程度効果的ですか? 関数の構成は、Haskellコンパイラーができることです。 彼は文字通りこのために生まれました! モノイドの知識を使用する利点については、差分リストdiffList



例を挙げます-準同型の構成の形式でリンクリストを実装します。 差分リストは、関数の構成の結合性により、多くの部分からのリストの形成を根本的に加速します。 ラッパー型の大騒ぎはオーバーヘッドの増加にはつながらず、コンパイル段階で「解消」します。 不要な作業のうち、ステータスチェックのみがプログラムの各ステップに残ります。









モノイドの結合



この瞬間までに懐疑論者やさりげない読者がすでに私たちを去っていると思うので、リラックスして次のレベルの抽象化に進むことができます。







セミグループとモノイドの概念は、例外なくすべてのセミグループとモノイドに固有のいくつかのプロパティがなければ、それほど有用で普遍的ではありません。これにより、単純な構造から複雑なプログラムを構築するのとまったく同じ方法で単純な構造から複雑な構造を構築できます。 これらのプロパティはオブジェクトではなく型に適用されるようになりました。数学的な表記ではなく、カリー-ハワード同型のおかげでその証明であるHaskellプログラムの形式で記述する方が適切です。







1)モノイドとセミグループは「乗算」できます。 これは、Haskellでの抽象化がタプルまたはペアである型の積を指します。







 instance (Semigroup a, Semigroup b) => Semigroup (a,b) where (a1, b1) <> (a2, b2) = (a1 <> a2, b1 <> b2) instance (Monoid a, Monoid b) => Monoid (a,b) where mempty = (mempty, mempty )
      
      





2)単一のモノイドがあり、単一のタイプ()



表されます。







 instance Semigroup () where () <> () = () instance Monoid () where mempty = ()
      
      





乗算の操作では、セミグループ自体がセミグループを形成し、ユニットタイプを考慮すると、モノイドがモノイドを形成すると言うことができます! 同時に、ユニットの結合性と中立性は同型に正確ですが、これは重要ではありません。







3)セミグループまたはモノイドのそれぞれ、セミグループまたはモノイドへのマッピング。 そして、ここでは、Haskellでこのステートメントを書くのも簡単です。







 instance Semigroup a => Semigroup (r -> a) where f <> g = \r -> fr <> gr instance Monoid a => Monoid (r -> a) where mempty = const mempty
      
      





これらのコンビネータを使用して、構築したスタック言語の機能を拡張します。 大きな変更を行い、 プログラムを返す基本的なコマンド関数を作成しましょう。 これにより、モノイドの特性が奪われることはありませんが、外部からの任意の情報をすべてのマシンコマンドの作業に入力できます。 意味は次のとおりです。







 (command1 <> command2) r == command1 r <> command2 r
      
      





情報は、たとえば、いくつかの定義を含む外部辞書、またはデバッグ中に必要な計算のログを保持する方法など、どのようなものでもかまいません。 これは、単なる機能であるモナドReader



動作に非常に似ています。







ログをマシンの構造に導入しますが、特定のタイプにバインドするのではなく、タイプパラメーターに出力します。 一般化されたモノイダル操作を使用してジャーナルに書き込みます。







 data VM a = VM { stack :: Stack , status :: Maybe String , memory :: Memory , journal :: a } deriving Show mkVM = VM mempty mempty (V.replicate memSize 0) setStack x (VM _ st ml) = VM x st ml setStatus st (VM s _ ml) = VM s st ml setMemory m (VM s st _ l) = VM s st ml addRecord x (VM s st mj) = VM s st m (x<>j) newtype Program a = Program { getProgram :: Action (VM a) } deriving (Semigroup, Monoid) type Program' a = (VM a -> VM a) -> Program a
      
      





これからは、すべての定義に型注釈を指定しないようにし、コンパイラーがそれらを個別に処理できるようにします。複雑になりませんが、面倒になります。 すべての変更を処理するスマートデザイナーのおかげで、チーム自体を変更する必要はありません。 かなり小さい。







新しいコンストラクターとコンビネーター。
 program fp = Program . Action $ \vm -> case status vm of Nothing -> p . (f (stack vm)) $ vm m -> vm programM fp = Program . Action $ \vm -> case status vm of Nothing -> p . (f (memory vm, stack vm)) $ vm m -> vm proceed p prog s = run (prog p) . setStack s rep body p = program go id where go (n:s) = proceed p (stimes n body) s go _ = err "rep expected an argument." branch br1 br2 p = program go id where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s go _ = err "branch expected an argument." while test body p = program (const go) id where go vm = let res = proceed p test (stack vm) vm in case (stack res) of 0:s -> proceed p mempty s res _:s -> go $ proceed p body s res _ -> err "while expected an argument." vm
      
      





外部情報をプログラム実行プログラムに入力することを教えることは残っています。 これは、異なるロギング戦略で異なるアーティストを作成することにより、非常に簡単に行えます。 最初のパフォーマーは、最もシンプルで、最も静かで、ジャーナルを維持する労力を無駄にしません







 exec prog = run (prog id) (mkVM ())
      
      





ここでは、単一のモノイド()



が有用でした-モノイド代数の中立要素。 さらに、ジャーナル内のマシンの状態に関するこの情報またはその情報を記録する準備ができているエグゼキューター用の関数を定義することができます。







 execLog p prog = run (prog $ \vm -> addRecord (p vm) vm) (mkVM mempty)
      
      





情報は、たとえば次のようなものです。







 logStack vm = [stack vm] logStackUsed = Max . length . stack logSteps = const (Sum 1) logMemoryUsed = Max . getSum . count . memory where count = foldMap (\x -> if x == 0 then 0 else 1)
      
      





:







 λ> exec (push 4 <> fact2) VM {stack = [24], status = Nothing, memory = [0,0,0,0], journal = ()} λ> journal $ execLog logSteps (push 4 <> fact2) Sum {getSum = 14} λ> mapM_ print $ reverse $ journal $ execLog logStack (push 4 <> fact2) [4] [3] [2,3] [3,2] [2,2] [3,2] [3,3,2] [4,3,2] [4,4,3,2] [5,4,3,2] [3,5,4,3,2] [2,4,3,2] [12,2] [24]
      
      





, , . :







 f &&& g = \r -> (fr, gr)
      
      











 λ> let report p = journal $ execLog (logSteps &&& logStackUsed) p λ> report (push 8 <> fact) (Sum {getSum = 48},Max {getMax = 10}) λ> report (push 8 <> fact1) (Sum {getSum = 63},Max {getMax = 4}) λ> report (push 8 <> fact2) (Sum {getSum = 26},Max {getMax = 9}) λ> report (push 8 <> fact3) (Sum {getSum = 43},Max {getMax = 3})
      
      





&&&



, . , Haskell . , .











. — , Haskell. .







, , — . , : . ( ) , ( ) . , , . - .







! :







 data Code = IF [Code] [Code] | REP [Code] | WHILE [Code] [Code] | PUT Int | GET Int | PUSH Int | POP | DUP | SWAP | EXCH | INC | DEC | NEG | ADD | MUL | SUB | DIV | EQL | LTH | GTH | NEQ deriving (Read, Show)
      
      





:







 fromCode :: [Code] -> Program' a fromCode = hom where hom = foldMap $ \case IF b1 b2 -> branch (hom b1) (hom b2) REP p -> rep (hom p) WHILE tb -> while (hom t) (hom b) PUT i -> put i GET i -> get i PUSH i -> push i POP -> pop DUP -> dup SWAP -> swap EXCH -> exch INC -> inc DEC -> dec ADD -> add MUL -> mul SUB -> sub DIV -> frac EQL -> eq LTH -> lt GTH -> gt NEQ -> neq NEG -> neg
      
      





, . foldMap



, . fromCode



, , , c:







 λ> stack $ exec (fromCode [PUSH 2, PUSH 5, EXCH, SUB, REP [DUP, INC]]) [5,4,3,2] λ> stack $ exec (fromCode $ read "[PUSH 2, PUSH 5, EXCH, SUB, REP [DUP, INC]]") [5,4,3,2]
      
      





, case



. : ! Program



:







 newtype Program a = Program { getProgram :: ([Code], Action (VM a)) } deriving (Semigroup, Monoid) run = runAction . snd . getProgram
      
      





run



, fromCode



:







 toCode :: Program' a -> [Code] toCode prog = fst . getProgram $ prog id
      
      





, . , :







 type Program' a = (Code -> VM a -> VM a) -> Program a program cfp = Program . ([c],) . Action $ \vm -> case status vm of Nothing -> pc . f (stack vm) $ vm _ -> vm programM cfp = Program . ([c],) . Action $ \vm -> case status vm of Nothing -> pc . f (memory vm, stack vm) $ vm _ -> vm
      
      





, , , . , -:







 none = const id exec prog = run (prog none) (mkVM ()) execLog p prog = run (prog $ \c -> \vm -> addRecord (pc vm) vm) (mkVM mempty) logStack _ vm = [stack vm] logStackUsed _ = Max . length . stack logSteps _ = const (Sum 1) --   logCode c _ = [c] logRun com vm = [pad 10 c ++ "| " ++ pad 20 s ++ "| " ++ m] where c = show com m = unwords $ show <$> toList (memory vm) s = unwords $ show <$> stack vm pad nx = take n (x ++ repeat ' ') debug :: Program' [String] -> String debug = unlines . reverse . journal . execLog logRun
      
      





 pop = program POP $ \case x:s -> setStack s _ -> err "POP expected an argument." push x = program (PUSH x) $ \s -> setStack (x:s) dup = program DUP $ \case x:s -> setStack (x:x:s) _ -> err "DUP expected an argument." swap = program SWAP $ \case x:y:s -> setStack (y:x:s) _ -> err "SWAP expected two arguments." exch = program EXCH $ \case x:y:s -> setStack (y:x:y:s) _ -> err "EXCH expected two arguments." app1 cf = program c $ \case x:s -> setStack (fx:s) _ -> err $ "operation " ++ show c ++ " expected an argument" app2 cf = program c $ \case x:y:s -> setStack (fxy:s) _ -> err $ "operation " ++ show c ++ " expected two arguments" add = app2 ADD (+) sub = app2 SUB (flip (-)) mul = app2 MUL (*) frac = app2 DIV (flip div) neg = app1 NEG (\x -> -x) inc = app1 INC (\x -> x+1) dec = app1 DEC (\x -> x-1) eq = app2 EQL (\x -> \y -> if (x == y) then 1 else 0) neq = app2 NEQ (\x -> \y -> if (x /= y) then 1 else 0) lt = app2 LTH (\x -> \y -> if (x > y) then 1 else 0) gt = app2 GTH (\x -> \y -> if (x < y) then 1 else 0) proceed p prog s = run (prog p) . setStack s rep body p = program (REP (toCode body)) go none where go (n:s) = if n >= 0 then proceed p (stimes n body) s else err "REP expected positive argument." go _ = err "REP expected an argument." branch br1 br2 p = program (IF (toCode br1) (toCode br2)) go none where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s go _ = err "IF expected an argument." while test body p = program (WHILE (toCode test) (toCode body)) (const go) none where go vm = let res = proceed p test (stack vm) vm in case (stack res) of 0:s -> proceed p mempty s res _:s -> go $ proceed p body s res _ -> err "WHILE expected an argument." vm put i = indexed (PUT i) i $ \case (m, x:s) -> setStack s . setMemory (m // [(i,x)]) _ -> err "PUT expected an argument" get i = indexed (GET i) i $ \(m, s) -> setStack ((m ! i) : s) indexed cif = programM c $ if (i < 0 || i >= memSize) then const $ err "index in [0,16]" else f
      
      





, ! , .







-, :







 λ> toCode fact1 [PUSH 1,SWAP,WHILE [DUP,PUSH 1,GTH] [SWAP,EXCH,MUL,SWAP,DEC],POP]
      
      





EDSL, .







-, , toCode



fromCode



-.







 λ> toCode $ fromCode [PUSH 5, PUSH 6, ADD] [PUSH 5, PUSH 6, ADD] λ> exec (fromCode $ toCode (push 5 <> push 6 <> add)) VM {stack = [11], status = Nothing, memory = [0,0,0,0], journal = ()}
      
      





, : , . ghci



fact



, , Ctrl+C



. , toCode



, .







, , , - :







 λ> putStrLn $ debug (push 3 <> fact) PUSH 3 | 3 | 0 0 0 0 DUP | 3 3 | 0 0 0 0 PUSH 2 | 2 3 3 | 0 0 0 0 LTH | 0 3 | 0 0 0 0 DUP | 3 3 | 0 0 0 0 DEC | 2 3 | 0 0 0 0 DUP | 2 2 3 | 0 0 0 0 PUSH 2 | 2 2 2 3 | 0 0 0 0 LTH | 0 2 3 | 0 0 0 0 DUP | 2 2 3 | 0 0 0 0 DEC | 1 2 3 | 0 0 0 0 DUP | 1 1 2 3 | 0 0 0 0 PUSH 2 | 2 1 1 2 3 | 0 0 0 0 LTH | 1 1 2 3 | 0 0 0 0 PUSH 1 | 1 1 2 3 | 0 0 0 0 MUL | 1 2 3 | 0 0 0 0 MUL | 2 3 | 0 0 0 0 MUL | 6 | 0 0 0 0
      
      









. . , , !







, . — . , , .







, : , . , , . !







, , :







 listing :: Program' a -> String listing = unlines . hom 0 . toCode where hom n = foldMap f where f = \case IF b1 b2 -> ouput "IF" <> indent b1 <> ouput ":" <> indent b2 REP p -> ouput "REP" <> indent p WHILE tb -> ouput "WHILE" <> indent t <> indent b c -> ouput $ show c ouput x = [stimes n " " ++ x] indent = hom (n+1)
      
      





: , , , .







:
 λ> putStrLn . listing $ fact2 INC PUSH 1 SWAP EXCH SUB DUP PUSH 0 GTH IF REP DUP INC : NEG REP DUP DEC DEC DEC REP MUL λ> putStrLn . listing $ gcd1 WHILE EXCH EXCH NEQ EXCH EXCH LTH IF : SWAP EXCH SUB POP
      
      





. , , . .







, — , . , . :









Rのi個のTのY追加= 2 1







他の演算子の価数は次のとおりです。





Rのi個のTのYプッシュ= 0 1Rのi個のTのYポップ= 1 0Rのi個のTのYEXCH= 2 3







なぜ私たちは常に予約をするのですか:最小数、最大要件..?実際、すべての基本的な演算子は正確に定義された結合価を持っていますが、分岐するとき、異なる分岐は異なる要件と結果を持つことができます。私たちのタスク:ブランチの数に関係なく、すべてのブランチの動作を保証する最も厳しい要件を計算すること。

原子価の順次実行では、コマンドは次の非自明な方法で結合されます。









I 1O 1I 2O 2= + I 1+ O 1 + O 2 - I 2a = max 0 i 2 - o 1







この操作は関連性があり、中立的な要素を持っています。これはモノイドに関する記事にとって驚くべきことではありません。この結果をプログラムに追加します。

 infix 7 :> data Arity = Int :> Int deriving (Show,Eq) instance Semigroup Arity where (i1 :> o1) <> (i2 :> o2) = let a = 0 `max` (i2 - o1) in (a + i1) :> (a + o1 + o2 - i2) instance Monoid Arity where mempty = 0:>0
      
      





そして準同型を構築できます:







 arity :: Program' a -> Arity arity = hom . toCode where hom = foldMap $ \case IF b1 b2 -> let i1 :> o1 = hom b1 i2 :> o2 = hom b2 in 1:>0 <> (i1 `max` i2):>(o1 `min` o2) REP p -> 1:>0 WHILE tb -> hom t <> 1:>0 PUT _ -> 1:>0 GET _ -> 0:>1 PUSH _ -> 0:>1 POP -> 1:>0 DUP -> 1:>2 SWAP -> 2:>2 EXCH -> 2:>3 INC -> 1:>1 DEC -> 1:>1 NEG -> 1:>1 _ -> 2:>1
      
      





, , . , , .







( ):







 λ> arity (exch <> exch) 2 :> 4 λ> arity fact1 1 :> 1 λ> arity range 2 :> 1 λ> arity (push 3 <> dup <> pow) 0 :> 1
      
      





? , "" . Program' a -> Max Int



, . , , :







 memoryUse :: Program' a -> Max Int memoryUse = hom . toCode where hom = foldMap $ \case IF b1 b2 -> hom b1 <> hom b2 REP p -> hom p WHILE tb -> hom t <> hom b PUT i -> Max (i+1) GET i -> Max (i+1) _ -> 0
      
      





 λ> memoryUse fact1 Max {getMax = 0} λ> memoryUse fact3 Max {getMax = 1} λ> memoryUse pow Max {getMax = 2}
      
      





. , .







, : , , , 0:>_



. . , .







 isReducible p = let p' = fromCode p in case arity p' of 0:>_ -> memoryUse p' == 0 _ -> False reducible = go [] . toCode where go res [] = reverse res go res (p:ps) = if isReducible [p] then let (a,b) = spanBy isReducible (p:ps) in go (a:res) b else go res ps --    Last,  , --     spanBy test l = case foldMap tst $ zip (inits l) (tails l) of Last Nothing -> ([],l) Last (Just x) -> x where tst x = Last $ if test (fst x) then Just x else Nothing --    Endo    --  intercalate  splitOn     -- Data.List  Data.List.Split reduce p = fromCode . process (reducible p) . toCode $ p where process = appEndo . foldMap (\x -> Endo $ x `replaceBy` shrink x) shrink = toCode . foldMap push . reverse . stack . exec . fromCode replaceBy xy = intercalate y . splitOn x
      
      





:







 λ> let p = push 6 <> fact1 <> swap <> push 5 <> dup <> push 14 <> gcd1 <> put 1 λ> toCode $ p [PUSH 6,PUSH 1,SWAP,WHILE [DUP,PUSH 1,GTH] [SWAP,EXCH,MUL,SWAP,DEC],POP,SWAP,PUSH 5,DUP,PUSH 14,WHILE [EXCH,EXCH,NEQ] [EXCH,EXCH,LTH,IF [] [SWAP],EXCH,SUB],POP,PUT 1] λ> toCode $ reduce p [PUSH 720,SWAP,PUSH 5,PUSH 1,PUT 1] λ> execLog logSteps (push 8 <> p) VM {stack = [5,8,720], status = Nothing, memory = [0,1,0,0], journal = Sum {getSum = 107}} λ> execLog logSteps (push 8 <> reduce p) VM {stack = [5,8,720], status = Nothing, memory = [0,1,0,0], journal = Sum {getSum = 6}}
      
      





最適化により、プログラムに必要なステップ数が107から6に削減されました。







, , , , - ( ).











: , , , ..? ? , , !







m



VM -> VM



VM -> m VM



, . : " — , ?!" , VM -> m VM



, , , . Haskell >=>



" ". , Action



ActionM



, :







 newtype ActionM ma = ActionM { runActionM :: a -> ma } instance Monad m => Semigroup (ActionM ma) where ActionM f <> ActionM g = ActionM (f >=> g) instance Monad m => Monoid (ActionM ma) where mempty = ActionM return
      
      





, , >=>



. .







 {-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving, TupleSections #-} import Data.Monoid hiding ((<>)) import Data.Semigroup (Semigroup(..),stimes,Max(..)) import Data.Vector ((//),(!),Vector,toList) import qualified Data.Vector as V (replicate) import Control.Monad import Control.Monad.Identity type Stack = [Int] type Memory = Vector Int memSize = 4 data VM a = VM { stack :: Stack , status :: Maybe String , memory :: Memory , journal :: a } deriving Show mkVM = VM mempty mempty (V.replicate memSize 0) setStack x (VM _ st ml) = return $ VM x st ml setStatus st (VM s _ ml) = return $ VM s st ml setMemory m (VM s st _ l) = return $ VM s st ml addRecord x (VM s st ml) = VM s st m (x<>l) ------------------------------------------------------------ data Code = IF [Code] [Code] | REP [Code] | WHILE [Code] [Code] | PUT Int | GET Int | PUSH Int | POP | DUP | SWAP | EXCH | INC | DEC | NEG | ADD | MUL | SUB | DIV | MOD | EQL | LTH | GTH | NEQ | ASK | PRT | PRTS String | FORK [Code] [Code] deriving (Read, Show) newtype ActionM ma = ActionM {runActionM :: a -> ma} instance Monad m => Semigroup (ActionM ma) where ActionM f <> ActionM g = ActionM (f >=> g) instance Monad m => Monoid (ActionM ma) where ActionM f `mappend` ActionM g = ActionM (f >=> g) mempty = ActionM return newtype Program ma = Program { getProgram :: ([Code], ActionM m (VM a)) } deriving (Semigroup, Monoid) type Program' ma = (Code -> VM a -> m (VM a)) -> Program ma program cfp = Program . ([c],) . ActionM $ \vm -> case status vm of Nothing -> pc =<< f (stack vm) vm m -> return vm programM cfp = Program . ([c],) . ActionM $ \vm -> case status vm of Nothing -> pc =<< f (memory vm, stack vm) vm m -> return vm run :: Monad m => Program ma -> VM a -> m (VM a) run = runActionM . snd . getProgram toCode :: Monad m => Program' ma -> [Code] toCode prog = fst . getProgram $ prog none none :: Monad m => Code -> VM a -> m (VM a) none = const return --     exec :: Program' Identity () -> VM () exec = runIdentity . execM execM :: Monad m => Program' m () -> m (VM ()) execM prog = run (prog none) (mkVM ()) execLog p prog = run (prog $ \c -> \vm -> return $ addRecord (pc vm) vm) (mkVM mempty) f &&& g = \c -> \r -> (fcr, gcr) logStack _ vm = [stack vm] logStackUsed _ = Max . length . stack logSteps _ = const (Sum 1) logCode c _ = [c] logRun com vm = [pad 10 c ++ "| " ++ pad 20 s ++ "| " ++ m] where c = show com m = unwords $ show <$> toList (memory vm) s = unwords $ show <$> stack vm pad nx = take n (x ++ repeat ' ') debug p = unlines . reverse . journal <$> execLog logRun p ------------------------------------------------------------ pop,dup,swap,exch :: Monad m => Program' ma put,get,push :: Monad m => Int -> Program' ma add,mul,sub,frac,modulo,inc,dec,neg :: Monad m => Program' ma eq,neq,lt,gt :: Monad m => Program' ma err m = setStatus . Just $ "Error : " ++ m pop = program POP $ \case x:s -> setStack s _ -> err "pop expected an argument." push x = program (PUSH x) $ \s -> setStack (x:s) dup = program DUP $ \case x:s -> setStack (x:x:s) _ -> err "dup expected an argument." swap = program SWAP $ \case x:y:s -> setStack (y:x:s) _ -> err "swap expected two arguments." exch = program EXCH $ \case x:y:s -> setStack (y:x:y:s) _ -> err "expected two arguments." put i = indexed (PUT i) i $ \case (m, x:s) -> setStack s <=< setMemory (m // [(i,x)]) _ -> err "put expected an argument" get i = indexed (GET i) i $ \(m, s) -> setStack ((m ! i) : s) indexed cif = programM c $ if (i < 0 || i >= memSize) then const $ err "index in [0,16]" else f app1 cf = program c $ \case x:s -> setStack (fx:s) _ -> err $ "operation " ++ show c ++ " expected an argument" app2 cf = program c $ \case x:y:s -> setStack (fxy:s) _ -> err $ "operation " ++ show c ++ " expected two arguments" add = app2 ADD (+) sub = app2 SUB (flip (-)) mul = app2 MUL (*) frac = app2 DIV (flip div) modulo = app2 MOD (flip mod) neg = app1 NEG (\x -> -x) inc = app1 INC (\x -> x+1) dec = app1 DEC (\x -> x-1) eq = app2 EQL (\x -> \y -> if (x == y) then 1 else 0) neq = app2 NEQ (\x -> \y -> if (x /= y) then 1 else 0) lt = app2 LTH (\x -> \y -> if (x > y) then 1 else 0) gt = app2 GTH (\x -> \y -> if (x < y) then 1 else 0) proceed p prog s = run (prog p) <=< setStack s rep body p = program (REP (toCode body)) go none where go (n:s) = if n >= 0 then proceed p (stimes n body) s else err "rep expected positive argument." go _ = err "rep expected an argument." branch br1 br2 p = program (IF (toCode br1) (toCode br2)) go none where go (x:s) = proceed p (if (x /= 0) then br1 else br2) s go _ = err "branch expected an argument." while test body p = program (WHILE (toCode test) (toCode body)) (const go) none where go vm = do res <- proceed p test (stack vm) vm case (stack res) of 0:s -> proceed p mempty s res _:s -> go =<< proceed p body s res _ -> err "while expected an argument." vm ask :: Program' IO a ask = program ASK $ \case s -> \vm -> do x <- getLine setStack (read x:s) vm prt :: Program' IO a prt = program PRT $ \case x:s -> \vm -> print x >> return vm _ -> err "PRT expected an argument" prtS :: String -> Program' IO a prtS s = program (PRTS s) $ const $ \vm -> print s >> return vm fork :: Program' [] a -> Program' [] a -> Program' [] a fork br1 br2 p = program (FORK (toCode br1) (toCode br2)) (const go) none where go = run (br1 p) <> run (br2 p) ------------------------------------------------------------ fromCode :: Monad m => [Code] -> Program' ma fromCode = hom where hom = foldMap $ \case IF b1 b2 -> branch (hom b1) (hom b2) REP p -> rep (hom p) WHILE tb -> while (hom t) (hom b) PUT i -> put i GET i -> get i PUSH i -> push i POP -> pop DUP -> dup SWAP -> swap EXCH -> exch INC -> inc DEC -> dec ADD -> add MUL -> mul SUB -> sub DIV -> frac MOD -> modulo EQL -> eq LTH -> lt GTH -> gt NEQ -> neq NEG -> neg _ -> mempty fromCodeIO :: [Code] -> Program' IO a fromCodeIO = hom where hom = foldMap $ \case IF b1 b2 -> branch (hom b1) (hom b2) REP p -> rep (hom p) WHILE tb -> while (hom t) (hom b) ASK -> ask PRT -> ask PRTS s -> prtS s c -> fromCode [c] fromCodeList :: [Code] -> Program' [] a fromCodeList = hom where hom = foldMap $ \case IF b1 b2 -> branch (hom b1) (hom b2) REP p -> rep (hom p) WHILE tb -> while (hom t) (hom b) FORK b1 b2 -> fork (hom b1) (hom b2) c -> fromCode [c]
      
      





: stdin



.







 ask, prt :: Program' IO a ask = program ASK $ \case s -> \vm -> do x <- getLine setStack (read x:s) vm prt = program PRT $ \case x:s -> \vm -> print x >> return vm _ -> err "PRT expected an argument" prtS :: String -> Program' IO a prtS s = program (PRTS s) $ const $ \vm -> print s >> return vm
      
      





- , :







 ioprog = prtS "input first number" <> ask <> prtS "input second number" <> ask <> rep (prt <> dup <> inc) <> prt
      
      





 λ> exec ioprog input first number 3 input second number 5 3 4 5 6 7 8 VM {stack = [8,7,6,5,4,3], status = Nothing, memory = [0,0,0,0], journal = ()}
      
      





, :







 fork :: Program' [] a -> Program' [] a -> Program' [] a fork br1 br2 p = program (FORK (toCode br1) (toCode br2)) (const go) pure where go = run (br1 p) <> run (br2 p)
      
      





: run



VM -> m VM



, — , , []



, — .







:







 λ> stack <$> exec (push 5 <> push 3 <> add `fork` sub) [[8],[2]] λ> stack <$> exec (push 5 <> push 3 `fork` dup <> push 2) [[2,3,5],[2,5,5]]
      
      





: 2 ± 3 4 ± 8 ± 5







 λ> let pm = add `fork` sub λ> stack <$> exec (push 2 <> push 3 <> push 4 <> push 8 <> pm <> push 5 <> pm <> pm <> mul) [[40],[-28],[20],[-8],[8],[4],[-12],[24]]
      
      





:







 λ> journal <$> execLog logSteps (push 8 <> fact `fork` fact1 `fork` fact2 `fork` fact3) [Sum {getSum = 48},Sum {getSum = 63},Sum {getSum = 34},Sum {getSum = 43}]
      
      





, fork



, , fork



.







. . , /, , .

















- μάγμα . , , , . , , , Lego: , - . , , , .







Lego , , — , , . , , . — ! , . , - . ( -) , . — ! "" , , , , . , , .










すべてのモジュールはリポジトリで利用可能ですソリューションのパフォーマンスを反映した図がコメントに追加されます。最も重要な結果は、クレイズリーカテゴリでモノイドを使用することです。これにより、メモリを使用するスタックマシンでのプログラムの実行速度が大幅に向上する可能が開かれます。プログラム構築の原則は変わりません。








All Articles