Mesin susun monoid

Belum lama ini, sebuah artikel yang sangat bagus dan inspiratif tentang kompiler dan mesin bertumpuk muncul di Habré. Ini menunjukkan jalan dari implementasi sederhana dari bytecode executor ke versi yang lebih efisien. Saya ingin menunjukkan pada contoh pengembangan mesin bertumpuk bagaimana ini dapat dilakukan dengan cara Haskell.

Dengan menggunakan interpretasi bahasa untuk mesin yang ditumpuk sebagai contoh, kita akan melihat bagaimana konsep matematika dari semi-grup dan monoids membantu mengembangkan dan memperluas arsitektur program, bagaimana menggunakan aljabar monoid dan bagaimana membangun program dalam bentuk seperangkat homomorfisme antara sistem aljabar. Sebagai contoh kerja, pertama-tama kita membangun juru bahasa yang tidak dapat dipisahkan dari kode dalam bentuk EDSL, dan kemudian mengajarkannya hal-hal yang berbeda: merekam informasi debugging yang sewenang-wenang, memisahkan kode program dari program itu sendiri, melakukan analisis statis sederhana dan menghitungnya dengan berbagai efek.

Artikel ini ditujukan bagi mereka yang mengetahui bahasa Haskell pada tingkat menengah ke atas, bagi mereka yang sudah menggunakannya dalam pekerjaan atau penelitian, dan untuk semua yang penasaran yang telah melirik untuk melihat apa yang belum dilakukan oleh para pejabat. Nah, bagi mereka, tentu saja, siapa paragraf sebelumnya tidak takut.

Ternyata banyak materi, dengan banyak contoh dalam kode, dan untuk membuatnya lebih mudah bagi pembaca untuk memahami apakah dia perlu menyelam ke dalamnya, saya akan memberikan konten beranotasi.

Tugas penerjemahan dan interpretasi memberikan banyak contoh menarik dan berguna untuk menunjukkan aspek pemrograman yang paling beragam. Mereka memungkinkan Anda untuk pergi ke berbagai tingkat kompleksitas dan abstraksi, sambil tetap cukup praktis. Pada artikel ini, kita akan fokus pada menunjukkan kemampuan dua struktur matematika yang penting - semigroup dan monoid . Mereka tidak dibahas sesering monad atau lensa, dan mereka tidak menakuti programmer kecil, struktur ini jauh lebih mudah dimengerti, tetapi untuk semua itu, mereka mendasari pemrograman fungsional. Penguasaan virtuoso tipe monoid, yang ditunjukkan oleh para profesional, mengagumi kesederhanaan dan keanggunan solusi.

Pencarian untuk kata "monoid" dalam artikel tentang Habré mengeluarkan tidak lebih dari empat lusin artikel (tentang monad yang sama, misalnya, ada tiga ratus di antaranya). Mereka semua secara konseptual mulai dengan sesuatu seperti: monoid sangat banyak ... dan kemudian, dengan antusiasme yang cukup dimengerti, mereka mendaftar apa itu monoid - dari garis ke pohon jari, dari parser ekspresi reguler hingga Tuhan yang tahu apa lagi ! Tetapi dalam praktiknya, kami berpikir dalam urutan yang berlawanan: kami memiliki objek yang perlu dimodelkan, kami menganalisis sifat-sifatnya dan menemukan bahwa ia memiliki tanda-tanda dari satu atau struktur abstrak lain, kami memutuskan: apakah kita memerlukan konsekuensi dari keadaan ini dan bagaimana kita menggunakannya. Kami akan pergi ke sini. Dan pada saat yang sama kami akan menambahkan beberapa contoh menarik ke koleksi monoids yang berguna.

Bahasa dan Program untuk Mesin Stack

Mesin tumpukan dalam studi pemrograman fungsional biasanya muncul pada saat mereka mendekati konsep konvolusi. Dalam hal ini, implementasi yang sangat ringkas dari pelaksana tumpukan kalkulator paling sederhana diberikan, misalnya, ini:

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." 

Awal yang bagus untuk percakapan! Kemudian, sebagai aturan, mereka mulai melampirkan efek: mereka mengubah konvolusi foldl ke foldM , memberikan totalitas melalui monad Either String , kemudian menambahkan logging, membungkus segala sesuatu dengan transformator WriterT , mengimplementasikan kamus StateT untuk variabel, dan sebagainya. Terkadang, untuk menunjukkan kesejukan perhitungan monadik, mereka menerapkan kalkulator ambigu yang mengembalikan semua nilai yang mungkin dari ekspresi $$$(2 \ pm 3) * ((4 \ pm 8) \ pm 5)$ . Ini adalah percakapan yang panjang, bagus dan menarik. Namun, kami akan segera memimpin cerita kami dengan cara yang berbeda, meskipun kami mengakhirinya dengan hasil yang sama.

Mengapa, secara umum, ini soal melipat? Karena konvolusi (katamorfisme) adalah abstraksi pemrosesan sekuensial data induktif . Mesin tumpukan berjalan secara linier melalui kode, menjalankan urutan instruksi dan menghasilkan satu nilai - keadaan tumpukan. Saya suka membayangkan karya mesin tumpukan convolutional sebagai menerjemahkan RNA matriks dalam sel hidup. Ribosom melewati seluruh rantai RNA selangkah demi selangkah, membandingkan kembar tiga nukleotida dengan asam amino dan menciptakan struktur utama protein.

Mesin konvolusi memiliki sejumlah keterbatasan, yang utama adalah bahwa program selalu dibaca dari awal hingga akhir dan sekali. Percabangan, pengulangan, dan panggilan subrutin membutuhkan perubahan konseptual pada juru bahasa. Tidak ada yang rumit, tentu saja, tetapi mesin seperti itu tidak dapat lagi digambarkan dengan belitan sederhana.

Menurut hipotesis relativitas linguistik, sifat-sifat bahasa yang kita gunakan secara langsung memengaruhi sifat-sifat pemikiran kita. Mari kita perhatikan bukan pada mesin, tetapi pada bahasa dan program yang dikontrolnya.

Semua bahasa berorientasi tumpukan, baik tingkat relatif rendah (bytecode Java dan Python atau. Mesin virtual NET) dan bahasa tingkat yang lebih tinggi (PostScript, Forth atau Joy), memiliki satu properti umum yang mendasar: jika Anda menulis dua program yang benar secara berurutan, maka dapatkan program yang benar. Benar, benar tidak berarti “benar”, program ini mungkin macet dengan kesalahan pada data apa pun atau gagal dalam siklus tanpa akhir dan tidak masuk akal sama sekali, tetapi yang utama adalah bahwa program seperti itu dapat dijalankan oleh mesin. Pada saat yang sama, memecah program yang benar menjadi beberapa bagian, kita dapat dengan mudah menggunakan kembali bagian-bagian ini, justru karena kebenarannya. Akhirnya, dalam bahasa stack apa pun, Anda dapat memilih subset perintah yang hanya beroperasi pada kondisi internal mesin (stack atau register), tidak menggunakan memori eksternal apa pun. Subset ini akan membentuk bahasa dengan properti penggabungan . Dalam bahasa seperti itu, program apa pun memiliki arti konverter keadaan mesin, dan eksekusi berurutan program setara dengan komposisi mereka, yang berarti juga konverter keadaan.

Pola umum sedang terlihat: kombinasi (rangkaian) dari program yang benar menghasilkan program yang benar, kombinasi konverter menghasilkan konverter. Ternyata program bahasa stack ditutup sehubungan dengan operasi penggabungan atau membentuk struktur yang disebut groupoid atau magma . Ini berarti bahwa Anda dapat, dengan menulis program untuk direkam, memotongnya hampir secara acak dan kemudian membentuk program baru dari segmen yang dihasilkan. Selain itu, Anda dapat memotong segmen dengan satu instruksi.

Saat mengikat, ketertiban penting. Sebagai contoh, kedua program ini tidak diragukan lagi berbeda:

Dan apa yang kita dapatkan sebagai programmer? Associativity memungkinkan Anda mengkompilasi, mengoptimalkan, dan bahkan memaralelkan bagian program yang sesuai untuk ini, dan kemudian menggabungkannya ke dalam program yang setara. Kami dapat melakukan analisis statis bagian mana pun dari program dan menggunakannya dalam analisis seluruh program secara tepat karena kami tidak peduli di mana harus meletakkan tanda kurung. Ini adalah peluang yang sangat penting dan serius untuk bahasa tingkat rendah atau bahasa perantara di mana bukan seseorang menulis, tetapi seorang penerjemah. Dan dari sudut pandang seorang ahli matematika dan pekerja fungsional berpengalaman, ini membuat program konversi negara mesin endomorfisma lengkap. Endomorfisme juga membentuk semigroup dengan operasi komposisi. Dalam aljabar, endomorfisme semacam itu disebut semigroup transformasi sehubungan dengan beberapa set. Sebagai contoh, mesin negara hingga membentuk semigroup transformasi banyak negara.

"Semigroup" terdengar setengah hati, entah bagaimana lebih rendah. Mungkin tumpukan program membentuk grup ? Uh ... tidak, sebagian besar program tidak dapat dipulihkan, yaitu, berdasarkan hasil eksekusi, tidak mungkin mengembalikan data asli secara ambigu. Tapi kami memiliki elemen netral. Dalam bahasa assembly, ini dilambangkan $$$\ texttt {nop}$ dan tidak melakukan apa-apa. Jika operator seperti itu tidak secara eksplisit didefinisikan dalam bahasa stack, maka dapat dengan mudah diperoleh dengan menggabungkan beberapa perintah, misalnya: $$$\ texttt {inc dec}$ , $$$\ texttt {dup pop}$ atau $$$\ texttt {swap swap}$ . Pasangan semacam itu dapat dengan aman dipotong dari program atau, sebaliknya, dimasukkan di mana saja dalam jumlah sewenang-wenang. Karena ada unit, program kami membentuk semi-grup dengan unit atau monoid . Jadi, Anda dapat secara terprogram mengimplementasikannya dalam bentuk monoids - endomorphisms di atas kondisi mesin yang ditumpuk. Ini akan memungkinkan Anda untuk mendefinisikan satu set kecil operasi dasar untuk mesin, dan kemudian membuat program menggunakan komposisi mereka, mendapatkan bahasa yang ditumpuk dalam bentuk bahasa khusus domain tertanam (EDSL).

Di Haskell, Semigroup - Semigroup dan Semigroup dijelaskan menggunakan kelas Semigroup dan Semigroup . Definisi mereka sederhana dan hanya mencerminkan struktur dasar, persyaratan asosiasi dan netralitas harus diperiksa oleh programmer:

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

Membangun mobil

 {-# LANGUAGE LambdaCase, GeneralizedNewtypeDeriving #-} import Data.Semigroup (Max(..),stimes) import Data.Monoid import Data.Vector ((//),(!),Vector) import qualified Data.Vector as V (replicate) 

Kami akan segera membangun mesin yang memiliki tumpukan, memori yang terbatas dan dapat berhenti darurat dengan cara yang baik dan bersih. Semua ini diwujudkan tanpa menggunakan monad, merangkum data yang diperlukan dalam jenis yang menggambarkan mesin. Dengan demikian, semua program dasar, dan karenanya semua kombinasinya, akan menjadi konverter murni dari kondisinya.

Mari kita mulai dengan mendefinisikan jenis untuk mesin virtual dan fungsi setter sepele.

 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 

Setter diperlukan untuk membuat program semantik eksplisit. Dengan prosesor (tipe Processor ) yang kami maksud adalah konverter VM -> VM .

Sekarang kita mendefinisikan tipe wrapper untuk monoid transformasi dan untuk program:

 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) 

Jenis wrapper menentukan prinsip penggabungan program: ini adalah endomorfisme dengan urutan komposisi terbalik (dari kiri ke kanan). Menggunakan pembungkus memungkinkan kompiler untuk secara independen menentukan bagaimana jenis Program mengimplementasikan persyaratan dari kelas Semigroup dan Semigroup .

Pelaksana program itu sepele:

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

Pesan kesalahan akan dihasilkan oleh fungsi err :

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

Kami menggunakan tipe Maybe tidak seperti yang biasanya digunakan: nilai Nothing kosong pada status berarti tidak ada hal berbahaya yang terjadi, dan perhitungan dapat dilanjutkan, pada gilirannya, nilai string menandakan masalah. Untuk kenyamanan, kami mendefinisikan dua konstruktor pintar: satu untuk program yang hanya bekerja dengan stack, dan yang lainnya untuk mereka yang membutuhkan memori.

 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 

Sekarang Anda dapat menentukan perintah bahasa dasar untuk bekerja dengan stack dan memori, aritmatika integer, dan juga hubungan ekivalensi dan ketertiban.

 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) 

Untuk operasi yang tepat, tidak ada cukup percabangan dan loop. Sebenarnya, untuk bahasa yang disematkan, hanya percabangan saja yang cukup, loop dapat diatur menggunakan rekursi dalam bahasa host (di Haskell), tetapi kami akan membuat bahasa kami mandiri. Selain itu, kami mengambil keuntungan dari fakta bahwa program membentuk semigroup dan menentukan kombinasi dari pengulangan program dengan jumlah yang ditentukan. Dia akan mengambil jumlah repetisi dari stack.

 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 

Jenis branch dan fungsi while menunjukkan bahwa ini bukan program yang berdiri sendiri, tetapi penggabung program: pendekatan khas saat membuat EDSL di Haskell. Fungsi stimes didefinisikan untuk semua stimes - stimes , ia mengembalikan komposisi jumlah elemen yang ditentukan.

Akhirnya, kami akan menulis beberapa program untuk eksperimen.

 --   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 

Ternyata 120 baris kode dengan komentar dan penjelasan jenis yang mendefinisikan mesin yang beroperasi dengan 18 perintah dengan tiga kombinator. Beginilah cara mobil kami bekerja.

 λ> 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]} 

Faktanya, kami tidak melakukan sesuatu yang baru - dengan menggabungkan konverter endomorfisme, kami pada dasarnya kembali ke konvolusi, tetapi menjadi implisit. Ingat bahwa konvolusi menyediakan abstraksi pemrosesan sekuensial data induktif. Data, dalam kasus kami, dihasilkan secara induktif ketika operator menempelkan program $$$\ berlian$ , dan mereka "disimpan" dalam endomorfisme dalam bentuk rantai komposisi fungsi pengubahan mesin sampai rantai ini diterapkan pada keadaan awal. Dalam kasus branch combinator dan while rantai mulai berubah menjadi pohon atau loop. Dalam kasus umum, kita mendapatkan grafik yang mencerminkan operasi otomat dengan memori toko, yaitu mesin bertumpuk. Struktur inilah yang kami "runtuh" ​​selama pelaksanaan program.

Seberapa efektif implementasi ini? Komposisi fungsi adalah yang terbaik yang dapat dilakukan oleh kompiler Haskell. Ia dilahirkan untuk ini! Ketika datang ke manfaat menggunakan pengetahuan monoids, mereka sering memberikan contoh daftar perbedaan diffList - menerapkan daftar terkait dalam bentuk komposisi endomorfisme. Daftar perbedaan secara mendasar mempercepat pembentukan daftar dari banyak bagian karena asosiasi komposisi fungsi. Repot dengan jenis pembungkus tidak menyebabkan peningkatan overhead, mereka "larut" pada tahap kompilasi. Dari pekerjaan ekstra, hanya pemeriksaan status yang tetap pada setiap langkah program.

Kombinasikan Monoids

Saya pikir pada saat ini para skeptis dan pembaca biasa telah meninggalkan kami, Anda dapat membiarkan diri Anda rileks dan naik ke tingkat abstraksi berikutnya.

Konsep semi-grup dan monoids tidak akan begitu berguna dan universal, jika tidak untuk serangkaian properti yang melekat pada semua semi-grup dan monoids tanpa kecuali, yang memungkinkan kita untuk membangun struktur kompleks dari struktur sederhana dengan cara yang sama seperti kita membangun program kompleks dari yang sederhana. Properti ini tidak lagi berlaku untuk objek, tetapi untuk tipe, dan lebih baik menulisnya bukan dalam notasi matematika, tetapi dalam bentuk program di Haskell, yang, berdasarkan isomorfisma Curry-Howard, adalah buktinya.

1) Monoids dan semi-grup dapat "dikalikan". Ini mengacu pada produk tipe, abstraksi yang dalam Haskell adalah tuple atau pasangan.

 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) Ada satu monoid, diwakili oleh satu tipe () :

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

Dengan operasi multiplikasi, semigroup itu sendiri membentuk semigroup, dan dengan mempertimbangkan tipe unit, kita dapat mengatakan bahwa monoids membentuk monoid! Asosiativitas dan netralitas suatu unit dipenuhi hingga isomorfisme, tetapi ini tidak penting.

3) Pemetaan ke dalam bentuk semi-grup atau monoid, masing-masing, semi-grup atau monoid. Dan di sini, juga lebih mudah untuk menulis pernyataan ini di Haskell:

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

Kami akan menggunakan kombinator ini untuk memperluas kemampuan bahasa stack yang telah kami buat. Mari kita membuat perubahan besar dan membuat fungsi perintah dasar kita yang mengembalikan program . Ini tidak akan menghilangkan properti monoid mereka, tetapi akan memungkinkan untuk memasukkan informasi sewenang-wenang dari luar ke dalam pekerjaan semua perintah mesin. Inilah yang dimaksud:

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

Informasi dapat berupa, misalnya, kamus eksternal dengan beberapa definisi, atau cara untuk menyimpan log perhitungan yang diperlukan selama proses debug. Ini sangat mirip dengan tindakan Reader monad, yang, hanya, hanyalah sebuah fungsi.

Kami akan memperkenalkan log ke dalam struktur mesin, tetapi kami tidak akan mengikatnya ke tipe tertentu, tetapi menampilkannya ke parameter tipe. Kami akan menulis ke jurnal menggunakan operasi monoid umum.

 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 

Mulai sekarang, kami mengizinkan diri kami untuk tidak menentukan jenis anotasi untuk semua definisi, membiarkan kompiler untuk mengatasinya secara independen, mereka tidak rumit, meskipun mereka menjadi rumit. Tim-tim itu sendiri tidak perlu diubah, terima kasih kepada perancang cerdas yang akan mengurus semua perubahan. Cukup kecil.

 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 

Masih mengajarkan untuk memasukkan informasi eksternal ke pelaksana program. Ini sangat mudah dilakukan dengan membuat seniman yang berbeda dengan strategi penebangan yang berbeda. Penampil pertama akan menjadi upaya paling sederhana, paling sunyi, tidak membuang waktu dalam membuat jurnal:

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

Di sini satu monoid () berguna bagi kita - elemen netral dalam aljabar monoid. Lebih lanjut, dimungkinkan untuk mendefinisikan suatu fungsi untuk pelaksana yang siap untuk merekam informasi ini atau itu tentang keadaan mesin dalam jurnal.

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

Informasi dapat berupa, misalnya, seperti:

 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) 

$$$\rightarrow$ :

 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] 

$$$\rightarrow$ , 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 

. , , . .

, — , . , . :

Saat menjalankan perintah valensi secara berurutan, mereka digabungkan dengan cara non-sepele berikut:

 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 

Dan kemudian Anda dapat membangun homomorfisme:

 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}} 

, , , , - ( ).

: , , , ..? ? , , !

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 \pm 3)*((4 \pm 8)\pm 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 , , — , , . , , . — ! , . , - . ( -) , . — ! "" , , , , . , , .

. - , . — , . .