मोनॉयड स्टैकिंग मशीन

इतना समय पहले नहीं, एक उत्कृष्ट और प्रेरक लेख कम्पाइलर और स्टैक्ड मशीनों के बारे में हैबे पर दिखाई दिया। यह एक बाईटेकोड निष्पादक के सरल कार्यान्वयन से अधिक से अधिक कुशल संस्करणों के लिए रास्ता दिखाता है। मैं एक खड़ी मशीन विकसित करने के उदाहरण पर दिखाना चाहता था कि हास्केल-वे में यह कैसे किया जा सकता है।

एक उदाहरण के रूप में एक खड़ी मशीन के लिए भाषा की व्याख्या का उपयोग करते हुए, हम देखेंगे कि कैसे अर्धवृत्त और मोनोइड्स की गणितीय अवधारणा कार्यक्रम की वास्तुकला को विकसित करने और विस्तारित करने में मदद करती है, कैसे मोनॉयड बीजगणित का उपयोग करें और बीजगणितीय प्रणालियों के बीच होमोमोर्फिज्म के सेट के रूप में कार्यक्रमों का निर्माण कैसे करें। काम के उदाहरणों के रूप में, हम पहले एक दुभाषिया का निर्माण करते हैं जो EDSL के रूप में कोड से अविभाज्य है, और फिर इसे अलग-अलग चीजें सिखाते हैं: मनमानी डिबगिंग जानकारी रिकॉर्ड करें, प्रोग्राम कोड को प्रोग्राम से अलग करें, सरल स्थैतिक विश्लेषण करें और विभिन्न प्रभावों के साथ गणना करें।

यह लेख उन लोगों के लिए अभिप्रेत है जो हास्केल भाषा को एक मध्यवर्ती स्तर पर और उससे ऊपर जानते हैं, उन लोगों के लिए जो पहले से ही काम या शोध में इसका उपयोग करते हैं, और उन सभी जिज्ञासुओं के लिए जो एक नज़र को देखने के लिए देखते हैं कि क्या कार्य करना बाकी है। खैर, उन लोगों के लिए, निश्चित रूप से, जिन्हें पिछले पैराग्राफ ने डरा नहीं था।

यह कोड में कई उदाहरणों के साथ बहुत सारी सामग्री निकला, और पाठक को यह समझने में आसान बनाने के लिए कि क्या उसे इसमें गोता लगाने की जरूरत है, मैं एनोटेट सामग्री दूंगा।

अनुवाद और व्याख्या कार्य प्रोग्रामिंग के सबसे विविध पहलुओं को प्रदर्शित करने के लिए कई दिलचस्प और उपयोगी उदाहरण प्रदान करते हैं। वे आपको काफी व्यावहारिक रहते हुए जटिलता और अमूर्तता के विभिन्न स्तरों पर जाने की अनुमति देते हैं। इस लेख में, हम दो महत्वपूर्ण गणितीय संरचनाओं की क्षमताओं का प्रदर्शन करने पर ध्यान केंद्रित करेंगे - एक अर्धवृत्त और एक मोनॉइड । उन्हें अक्सर साधु या लेंस के रूप में चर्चा नहीं की जाती है, और वे छोटे प्रोग्रामर को डराते नहीं हैं, इन संरचनाओं को समझना बहुत आसान है, लेकिन इन सभी के लिए, वे कार्यात्मक प्रोग्रामिंग से गुजरते हैं। मोनोइडल प्रकारों की पुण्योसो मास्टर, जो पेशेवरों द्वारा प्रदर्शित की जाती है, समाधान की सादगी और लालित्य की प्रशंसा करती है।

हैबे पर लेखों में "मोनॉइड" शब्द की खोज चार दर्जन से अधिक लेख (एक ही भिक्षु के बारे में) उदाहरण के लिए, उनमें से तीन सौ हैं। वे सभी वैचारिक रूप से कुछ के साथ शुरू करते हैं जैसे: एक मोनॉइड बहुत सारे हैं ... और फिर, काफी समझ से उत्साह के साथ, वे यह सूचीबद्ध करते हैं कि एक मोनॉइड क्या है - लाइनों से लेकर उंगली के पेड़ तक, नियमित अभिव्यक्ति पार्सर्स से भगवान को और क्या पता है ! लेकिन व्यवहार में, हम विपरीत क्रम में सोचते हैं: हमारे पास एक ऐसी वस्तु है जिसे मॉडलिंग करने की आवश्यकता है, हम इसके गुणों का विश्लेषण करते हैं और पाते हैं कि इसमें एक या किसी अन्य अमूर्त संरचना के संकेत हैं, हम तय करते हैं: क्या हमें इस परिस्थिति से परिणाम की आवश्यकता है और हम इसका उपयोग कैसे करते हैं। हम इस तरह से जाएंगे। और उसी समय हम उपयोगी उदाहरणों के संग्रह में कुछ दिलचस्प उदाहरण जोड़ेंगे।

स्टैक मशीनों के लिए भाषा और कार्यक्रम

कार्यात्मक प्रोग्रामिंग के अध्ययन में स्टैक मशीनें आमतौर पर उस समय दिखाई देती हैं जब वे दृढ़ संकल्प की अवधारणा से संपर्क करती हैं। इस मामले में, सबसे सरल स्टैक कैलकुलेटर के निष्पादक का एक अत्यंत संक्षिप्त कार्यान्वयन दिया जाता है, उदाहरण के लिए, यह:

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

बातचीत की शानदार शुरुआत! फिर, एक नियम के रूप में, वे प्रभाव को संलग्न करना शुरू करते हैं: वे foldl को foldM करने के लिए foldM , Either String foldM माध्यम से समग्रता प्रदान करते हैं, फिर लॉगिंग जोड़ते हैं, WriterT ट्रांसफार्मर के साथ सब कुछ लपेटते हैं, चर के लिए StateT शब्दकोश को लागू करते हैं, और इसी तरह। कभी-कभी, राक्षसी गणनाओं की शीतलता को प्रदर्शित करने के लिए, वे एक अस्पष्ट कैलकुलेटर को लागू करते हैं जो अभिव्यक्ति के सभी संभावित मूल्यों को वापस करता है $$$(2 \ pm 3) * ((4 \ pm 8) \ pm 5)$ । यह एक लंबी, अच्छी और दिलचस्प बातचीत है। हालांकि, हम तुरंत अपनी कहानी को एक अलग तरीके से आगे बढ़ाएंगे, हालांकि हम इसे उसी परिणाम के साथ समाप्त करते हैं।

क्यों, सामान्य तौर पर, यह तह के बारे में है? क्योंकि कनवल्शन (कैटामोर्फिज्म) आगमनात्मक डेटा के अनुक्रमिक प्रसंस्करण का एक अमूर्त है । स्टैक मशीन कोड के माध्यम से रैखिक रूप से चलती है, निर्देशों के अनुक्रम को निष्पादित करती है और एक मान उत्पन्न करती है - स्टैक की स्थिति। मैं एक जीवित सेल में मैट्रिक्स आरएनए के अनुवाद के रूप में एक दृढ़ स्टैक मशीन के काम की कल्पना करना पसंद करता हूं। राइबोसोम पूरे आरएनए श्रृंखला चरण के माध्यम से कदम से गुजरता है, अमीनो एसिड के साथ न्यूक्लियोटाइड्स के ट्रिपल की तुलना करता है और प्रोटीन की प्राथमिक संरचना बनाता है ।

सजा मशीन में कई सीमाएँ हैं, मुख्य बात यह है कि कार्यक्रम को हमेशा शुरुआत से अंत तक और एक बार पढ़ा जाता है। ब्रांचिंग, लूप्स और सबरूटीन कॉल को दुभाषिया में एक वैचारिक परिवर्तन की आवश्यकता होती है। कुछ भी जटिल नहीं है, लेकिन इस तरह की मशीन को अब एक सरल दृढ़ संकल्प द्वारा वर्णित नहीं किया जा सकता है।

भाषाई सापेक्षता की परिकल्पना के अनुसार, हम जिस भाषा का उपयोग करते हैं, वह हमारी सोच के गुणों को सीधे प्रभावित करती है। आइए मशीन पर नहीं, बल्कि उन भाषाओं और कार्यक्रमों पर ध्यान दें जो इसे नियंत्रित करते हैं।

सभी स्टैक-ओरिएंटेड भाषाएं, दोनों अपेक्षाकृत निम्न-स्तर (जावा और पायथन या .NET वर्चुअल मशीन के बायोटेक) और उच्च स्तर की भाषाएँ (पोस्टस्क्रिप्ट, फोर्थ या जॉय), एक मौलिक सामान्य संपत्ति है: यदि आप अनुक्रम में दो सही प्रोग्राम लिखते हैं, तो सही कार्यक्रम प्राप्त करें। सही, सही का अर्थ "सही" नहीं है, यह प्रोग्राम किसी भी डेटा पर त्रुटि के साथ दुर्घटनाग्रस्त हो सकता है या अंतहीन चक्रों में विफल हो सकता है और इसका कोई मतलब नहीं होगा, लेकिन मुख्य बात यह है कि इस तरह के कार्यक्रम को मशीन द्वारा निष्पादित किया जा सकता है। उसी समय, सही प्रोग्राम को भागों में तोड़कर, हम आसानी से इन भागों का पुन: उपयोग कर सकते हैं, ठीक उनकी शुद्धता के कारण। अंत में, किसी भी स्टैक भाषा में, आप उन कमांड्स के सबसेट का चयन कर सकते हैं जो केवल मशीन की आंतरिक स्थिति (स्टैक या रजिस्टर) पर काम करते हैं, किसी बाहरी मेमोरी का उपयोग नहीं करते। यह उपसमूह अवशिष्ट की संपत्ति के साथ एक भाषा का निर्माण करेगा। ऐसी भाषा में, किसी भी प्रोग्राम का अर्थ मशीन स्टेट कन्वर्टर होता है, और प्रोग्राम्स का क्रमिक निष्पादन उनकी रचना के बराबर होता है, जिसका अर्थ है कि यह स्टेट कन्वर्टर भी है।

सामान्य पैटर्न को देखा जा रहा है: सही कार्यक्रमों का संयोजन (संयोजन) सही कार्यक्रम उत्पन्न करता है, कन्वर्टर्स का संयोजन कनवर्टर उत्पन्न करता है। यह पता चला है कि स्टैक लैंग्वेज प्रोग्राम्स को कॉन्टेक्शन ऑपरेशन के संबंध में बंद कर दिया जाता है या एक समूह या मैगमा नामक संरचना का निर्माण किया जाता है। इसका मतलब यह है कि आप प्रोग्राम को टेप करने के लिए लिख सकते हैं, इसे लगभग यादृच्छिक रूप से काट सकते हैं और फिर परिणामी खंडों से नए कार्यक्रम बना सकते हैं। इसके अलावा, आप एकल निर्देश के साथ खंडों तक काट सकते हैं।

जब बॉन्डिंग, ऑर्डर महत्वपूर्ण है। उदाहरण के लिए, ये दो कार्यक्रम निस्संदेह अलग हैं:

और यह हमें प्रोग्रामर के रूप में क्या देता है? संबद्धता आपको इसके लिए मनमाने ढंग से उपयुक्त प्रोग्राम सेक्शन को पूर्वनिर्धारित, ऑप्टिमाइज़ करने और यहां तक ​​कि समानांतर करने की अनुमति देती है और फिर उन्हें एक समतुल्य प्रोग्राम में जोड़ती है। हम कार्यक्रम के किसी भी हिस्से का स्थैतिक विश्लेषण कर सकते हैं और इसका उपयोग पूरे कार्यक्रम के विश्लेषण में सटीक रूप से कर सकते हैं क्योंकि हमें परवाह नहीं है कि कोष्ठक कहां लगाए जाएं। ये निम्न-स्तरीय भाषा या मध्यवर्ती भाषा के लिए बहुत महत्वपूर्ण और गंभीर अवसर हैं, जिसमें कोई व्यक्ति लिखता नहीं है, लेकिन एक अनुवादक है। और एक गणितज्ञ और एक अनुभवी कार्यात्मक कार्यकर्ता के दृष्टिकोण से, यह मशीन राज्य-रूपांतरण कार्यक्रमों को पूर्ण- एंडोमॉर्फिज़्म बनाता है। एंडोमोर्फिज्म एक रचना ऑपरेशन के साथ एक अर्धवृत्त भी बनाते हैं। बीजगणित में, इस तरह के एंडोमोर्फिज्म को कुछ सेट के संबंध में ट्रांसफ़ॉर्मिंग सेमीफ़ाइगर कहा जाता है। उदाहरण के लिए, परिमित राज्य मशीनें कई राज्यों के परिवर्तन का एक मुख्य भाग बनाती हैं।

"सेमिग्रुप" आधे-अधूरे, किसी तरह हीन लगता है। शायद स्टैक प्रोग्राम एक समूह बनाते हैं? उह ... नहीं, अधिकांश कार्यक्रम अपरिवर्तनीय हैं, अर्थात्, निष्पादन के परिणाम के अनुसार, मूल डेटा को स्पष्ट रूप से पुनर्स्थापित करना संभव नहीं होगा। लेकिन हमारे पास एक तटस्थ तत्व है। विधानसभा भाषाओं में, इसे निरूपित किया जाता है $$$\ texttt {nop}$ और कुछ नहीं करता। यदि इस तरह के ऑपरेटर को स्टैक भाषा में स्पष्ट रूप से परिभाषित नहीं किया गया है, तो इसे आसानी से कुछ कमांडों को मिलाकर प्राप्त किया जा सकता है, उदाहरण के लिए: $$$\ texttt {inc dec}$ । $$$\ texttt {डुबकी पॉप}$ या $$$\ texttt {स्वैप स्वैप}$ । इस तरह के जोड़े को कार्यक्रमों से सुरक्षित रूप से काटा जा सकता है या इसके विपरीत, एक मनमानी राशि में कहीं भी डाला जा सकता है। चूंकि एक इकाई है, हमारे कार्यक्रम एक इकाई या मोनॉयड के साथ एक अर्धवृत्त बनाते हैं। तो, आप प्रोग्राम कर सकते हैं उन्हें मोनोइड के रूप में लागू कर सकते हैं - स्टैक्ड मशीन की स्थिति पर एंडोमोर्फिज्म। यह आपको मशीन के लिए बुनियादी संचालन के एक छोटे सेट को परिभाषित करने की अनुमति देगा, और फिर उनकी रचना का उपयोग करके प्रोग्राम बना सकता है, एक एम्बेडेड डोमेन-विशिष्ट भाषा (EDSL) के रूप में एक खड़ी भाषा प्राप्त कर सकता है।

हास्केल में, Semigroup और मोनोइड को Semigroup और 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 ।

अब हम ट्रांसफॉर्मर मोनोइड और प्रोग्राम के लिए रैपर प्रकारों को परिभाषित करते हैं:

 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 की आवश्यकताओं को कैसे लागू करता है।

कार्यक्रम निष्पादक तुच्छ है:

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

त्रुटि संदेश गलत फ़ंक्शन द्वारा उत्पन्न किया जाएगा:

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

हम Maybe टाइप का उपयोग नहीं करते हैं जैसा कि आमतौर पर उपयोग किया जाता है: स्थिति में खाली शून्य मान का अर्थ है कि कुछ भी खतरनाक नहीं हो रहा है, और गणना जारी रखी जा सकती है, बदले में, स्ट्रिंग मान समस्याओं का संकेत देता है। सुविधा के लिए, हम दो स्मार्ट कंस्ट्रक्टर्स को परिभाषित करते हैं: एक उन कार्यक्रमों के लिए जो केवल स्टैक के साथ काम करते हैं, और दूसरा उन लोगों के लिए जिन्हें मेमोरी की आवश्यकता होती है।

 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) 

उचित संचालन के लिए, पर्याप्त ब्रांचिंग और लूप नहीं है। दरअसल, एम्बेडेड भाषा के लिए, केवल ब्रांचिंग पर्याप्त है, मेजबान भाषा (हास्केल) में पुनरावृत्ति का उपयोग करके लूप का आयोजन किया जा सकता है, लेकिन हम अपनी भाषा को आत्मनिर्भर बनाएंगे। इसके अलावा, हम इस तथ्य का लाभ उठाते हैं कि प्रोग्राम एक सेमीग्रुप बनाते हैं और प्रोग्राम रिपीटिशन के कॉम्बिनेटर को कई बार निर्धारित करते हैं। वह ढेर से दोहराव की संख्या ले जाएगा।

 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 संकेत मिलता है कि ये स्टैंड-अलोन प्रोग्राम नहीं हैं, लेकिन प्रोग्राम कॉम्बिनेटर: हास्केल में ईडीएसएल बनाते समय एक विशिष्ट दृष्टिकोण। सभी stimes लिए 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 

यह कोड की 120 लाइनों को टिप्पणियों और प्रकारों के एनोटेशन के साथ बदल देता है जो एक मशीन को परिभाषित करता है जो तीन कॉम्बिनेटर के साथ 18 कमांडों के साथ संचालित होता है। इसी तरह से हमारी कार काम करती है।

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

वास्तव में, हमने कुछ भी नया नहीं किया - एंडोमोर्फिज्म कन्वर्टर्स के संयोजन से, हम अनिवार्य रूप से सजा में लौट आए, लेकिन यह निहित है। स्मरण करो कि दृढ़ संकल्प प्रेरक डेटा के अनुक्रमिक प्रसंस्करण का एक अमूर्त प्रदान करता है। डेटा, हमारे मामले में, जब ऑपरेटर कार्यक्रमों को glues करता है, तो यह इंडक्टिवली उत्पन्न होता है $$$\ _ हीरा$ , और वे इस प्रक्रिया को प्रारंभिक अवस्था में लागू होने तक मशीन रूपांतरण कार्यों की एक श्रृंखला के रूप में एंडोमोर्फ़िज्म में "संग्रहीत" होते हैं। कॉम्बिनेटर branch के मामले में और while श्रृंखला एक पेड़ या लूप में बदलना शुरू कर देती है। सामान्य स्थिति में, हमें स्टोर मेमोरी के साथ एक ऑटोमेटन के संचालन को दर्शाते हुए एक ग्राफ मिलता है, अर्थात् एक खड़ी मशीन। यह इस संरचना है कि हम कार्यक्रम के निष्पादन के दौरान "पतन" करते हैं।

यह कितना प्रभावी है? कार्यों की संरचना सबसे अच्छा है जो हास्केल संकलक कर सकता है। वह सचमुच इसके लिए पैदा हुआ है! जब यह diffList ज्ञान का उपयोग करने के लाभों की बात आती है, तो वे अक्सर अंतर सूचियों का एक उदाहरण देते हैं। एक सूची - एंडोमोर्फिज्म की रचना के रूप में एक लिंक की गई सूची को लागू करना। कार्यों की संरचना की संबद्धता के कारण अंतर सूचियां मौलिक रूप से कई टुकड़ों से सूचियों के निर्माण में तेजी लाती हैं। रैपर प्रकार के साथ उपद्रव के कारण ओवरहेड में वृद्धि नहीं होती है, वे संकलन चरण में "भंग" करते हैं। अतिरिक्त काम में से, कार्यक्रम के प्रत्येक चरण में केवल एक स्थिति की जांच बनी हुई है।

Monoids का मिश्रण

मुझे लगता है कि इस समय तक संशयवादियों और आकस्मिक पाठकों ने हमें पहले ही छोड़ दिया है, आप खुद को आराम करने और अमूर्त स्तर पर जाने की अनुमति दे सकते हैं।

यदि सभी अपवादों और अपवादों के बिना निहित गुणों की एक श्रृंखला के लिए नहीं, जो हमें सरल संरचनाओं से जटिल संरचनाओं का निर्माण करने की अनुमति देता है, तो हम सेग्मेंट और मोनॉयड्स की अवधारणा इतनी उपयोगी और सार्वभौमिक नहीं होगी, जैसे कि हम सरल संरचनाओं से जटिल प्रोग्राम बनाते हैं। ये गुण अब वस्तुओं पर नहीं, बल्कि प्रकारों पर लागू होते हैं, और उन्हें गणितीय अंकन में नहीं लिखना बेहतर है, लेकिन हास्केल में कार्यक्रमों के रूप में, जो कि करी-हावर्ड आइसोमोर्फिज्म के आधार पर उनके प्रमाण हैं।

1) मोनोइड्स और सूजीग्रुप्स को "गुणा" किया जा सकता है। यह प्रकारों के उत्पाद को संदर्भित करता है, जिसमें हास्केल का अमूर्त एक टपल या युग्म है।

 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 = () 

गुणन के संचालन के साथ, अर्धवृत्त स्वयं एक अर्धवृत्त बनाते हैं, और इकाई प्रकार को ध्यान में रखते हुए, हम कह सकते हैं कि monoids एक monoid बनाते हैं! एक इकाई की सहानुभूति और तटस्थता isomorphism तक पूरी हो जाती है, लेकिन यह महत्वपूर्ण नहीं है।

3) एक अर्धवृत्त या मोनोड रूप में मैपिंग, क्रमशः, एक सेमीग्रुप या मोनोइड। और यहाँ, हास्केल में इस कथन को लिखना भी आसान है:

 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) 

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

. , , . .

, — , . , . :

जब क्रमिक रूप से वैधता आदेशों को निष्पादित करते हैं, तो वे निम्नलिखित गैर-तुच्छ तरीके से संयुक्त होते हैं:

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

, , , , - ( ).

: , , , ..? ? , , !

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 , , — , , . , , . — ! , . , - . ( -) , . — ! "" , , , , . , , .

. - , . — , . .