آلة التراص أحادية


منذ وقت ليس ببعيد ، ظهرت مقالة ممتازة وملهمة عن المترجمين والآلات المكدسة على حبري. يظهر الطريق من تنفيذ بسيط لمنفذ بايت إلى إصدارات أكثر فاعلية. أردت أن أعرض على مثال تطوير آلة مكدسة كيف يمكن القيام بذلك بطريقة هاسكل.


باستخدام تفسير اللغة لآلة مكدسة كمثال ، سنرى كيف يساعد المفهوم الرياضي للمجموعات شبه الأحادية على تطوير وتوسيع بنية البرنامج ، وكيفية استخدام الجبر الأحادي وكيفية بناء البرامج في شكل مجموعة من الأشكال المتجانسة بين أنظمة الجبر. كأمثلة عاملة ، نقوم أولاً ببناء مترجم لا ينفصل عن الرمز في شكل EDSL ، ثم نعلمه أشياء مختلفة: تسجيل معلومات التصحيح التعسفي ، وفصل كود البرنامج عن البرنامج نفسه ، وإجراء تحليل ثابت بسيط وحسابه مع تأثيرات مختلفة.


هذا المقال مخصص لأولئك الذين يعرفون لغة هاسكل على مستوى متوسط ​​وما فوق ، ولأولئك الذين يستخدمونها بالفعل في العمل أو البحث ، ولجميع الفضوليين الذين ألقوا نظرة على نظرة لمعرفة ما لم يفعله الموظفون بعد. حسنا ، بالنسبة لأولئك ، بالطبع ، الذين لم تخيفهم الفقرة السابقة.


اتضح الكثير من المواد ، مع العديد من الأمثلة في التعليمات البرمجية ، ولتسهيل على القارئ أن يفهم ما إذا كان يحتاج إلى الغوص فيها ، سأقدم محتوى تعليقيًا.


محتوى المقالة
  • لغات وبرامج الآلات المكدسة. يتم النظر في الميزات الهيكلية للغات الآلات المكدسة التي يمكن استخدامها لتنفيذ المترجم.
  • اصنع سيارة. رمز المترجم للآلة المكدسة مع الذاكرة ، استنادًا إلى أحاديات التحويل ، أكثر أو أقل تفصيلاً.
  • اجمع بين monoids. باستخدام الجبر الأحادي ، نضيف إلى تسجيل حساب المترجم ، مع أنواع السجلات العشوائية تقريبًا.
  • البرامج وقوانينها. نحن نبني تشابهًا بين البرنامج ورمزه ، مما يجعل من الممكن تشغيلهما بشكل منفصل.
  • إطلاق أحادي. تستخدم الأشكال المثلية الجديدة من البرامج إلى الهياكل الأخرى للإدراج المنسق والتحليل الثابت وتحسين الشفرة.
  • من monoids إلى monads ومرة ​​أخرى إلى monoids. نقوم ببناء الأشكال المتجانسة في عناصر من فئة Claysley التي تفتح إمكانيات استخدام monads. توسيع المترجم باستخدام أوامر الإدخال / الإخراج وحسابات غامضة.

تقدم مهام الترجمة التحريرية والشفوية العديد من الأمثلة المفيدة والمفيدة لتوضيح الجوانب الأكثر تنوعًا في البرمجة. تسمح لك بالانتقال إلى مستويات مختلفة من التعقيد والتجريد ، بينما تظل عملية تمامًا. في هذه المقالة ، سنركز على توضيح إمكانات هيكليتين رياضيتين مهمتين - مجموعة شبه وحيدة . لا يتم مناقشتها في كثير من الأحيان مثل monads أو العدسات ، ولا تخيف المبرمجين الصغار ، فهذه الهياكل أسهل بكثير في الفهم ، ولكن لكل ذلك ، فهي تكمن وراء البرمجة الوظيفية. إن البراعة الفريدة للأنواع الأحادية ، والتي يظهرها المحترفون ، تعجب ببساطة وأناقة الحلول.


البحث عن كلمة "monoid" في مقالات عن حبري لا تصدر أكثر من أربع وعشرون مقالة (حول نفس الموندات على سبيل المثال ، هناك ثلاثمائة منها). يبدأون جميعًا من الناحية المفاهيمية بشيء مثل: المونويد كثير جدًا ... ثم ، بحماس مفهومة تمامًا ، يسردون ما هو المونويد - من الخطوط إلى أشجار الأصابع ، من المحللون للتعبير العادي إلى الله يعرف ماذا ! لكن من الناحية العملية ، نعتقد في الترتيب المعاكس: لدينا كائن يحتاج إلى نمذجة ، ونحلل خصائصه ونجد أنه يحتوي على علامات على بنية مجردة أو أخرى ، نقرر: هل نحتاج إلى عواقب من هذا الظرف وكيف نستخدمه. سنذهب بهذه الطريقة. وفي الوقت نفسه ، سنضيف بضعة أمثلة مثيرة للاهتمام إلى مجموعة الأحاديات المفيدة.



لغات وبرامج ماكينات التكديس


عادة ما تظهر آلات التكديس في دراسة البرمجة الوظيفية في اللحظة التي تقترب فيها من مفهوم الالتواء. في هذه الحالة ، يتم إعطاء تنفيذ دقيق للغاية لمنفذ أبسط آلة حاسبة ، على سبيل المثال ، هذا:


أبسط حاسبة المكدس
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." 

ويستخدم المحلل اللغوي الكلي readMaybe من الوحدة النمطية Text.Read . يمكن للمرء أن يجعل البرنامج أقصر مرتين ، ولكن بدون رسائل خطأ مفيدة ، وهو أمر قبيح.


بداية رائعة للمحادثة! ثم ، كقاعدة عامة ، يبدأون في إرفاق التأثيرات: foldl التفاف foldl إلى foldM ، ويوفرون المجموع من خلال Either String monad ، ثم يضيفون التسجيل ، WriterT كل شيء باستخدام محول WriterT ، StateT قاموس StateT للمتغيرات ، وما إلى ذلك. في بعض الأحيان ، لإثبات برودة الحسابات الأحادية ، يقومون بتنفيذ آلة حاسبة غامضة تُرجع جميع القيم الممكنة للتعبير ( 2 م 3 ) ( ( 4 م 8 ) م 5 )   ممم . هذه محادثة طويلة وجيدة ومثيرة للاهتمام. ومع ذلك ، سنقود قصتنا على الفور بطريقة مختلفة ، على الرغم من أننا ننهيها بنفس النتيجة.


لماذا ، بشكل عام ، يتعلق الأمر بالطي؟ لأن الالتواء (catamorphism) هو تجريد للمعالجة التسلسلية للبيانات الاستقرائية . تعمل آلة المكدس خطيًا من خلال التعليمات البرمجية ، وتنفذ سلسلة من التعليمات وتولد قيمة واحدة - حالة المكدس. أحب أن أتخيل عمل مكدس تلافيفي مثل ترجمة المصفوفة RNA في خلية حية. يمر الريبوسوم عبر سلسلة RNA بالكامل خطوة بخطوة ، ويقارن ثلاثة توائم من النيوكليوتيدات مع الأحماض الأمينية ويخلق البنية الأساسية للبروتين.


تحتوي آلة الالتفاف على عدد من القيود ، الشيء الرئيسي هو أن البرنامج يتم قراءته دائمًا من البداية إلى النهاية ومرة ​​واحدة. تتطلب التفرعات والحلقات والمكالمات الروتينية تغيير مفاهيمي للمترجم. لا شيء معقد ، بالطبع ، ولكن لم يعد من الممكن وصف مثل هذه الآلة من خلال الالتواء البسيط.


وفقًا لفرضية النسبية اللغوية ، تؤثر خصائص اللغة التي نستخدمها بشكل مباشر على خصائص تفكيرنا. دعونا لا ننتبه للآلة ، ولكن للغات والبرامج التي تتحكم فيها.


جميع اللغات الموجهة إلى المكدس ، سواء على مستوى منخفض نسبيًا (رموز بايت Java و Python أو .NET الظاهري الأجهزة) ولغات ذات مستوى أعلى (PostScript أو Forth أو Joy) ، لها خاصية مشتركة أساسية واحدة: إذا كتبت برنامجين صحيحين بالتسلسل ، فعندئذٍ احصل على البرنامج الصحيح. صحيح ، صحيح لا يعني "صحيح" ، قد يتعطل هذا البرنامج مع وجود خطأ في أي بيانات أو يفشل في دورات لا نهاية لها وليس له أي معنى على الإطلاق ، ولكن الشيء الرئيسي هو أنه يمكن تنفيذ مثل هذا البرنامج بواسطة الجهاز. في نفس الوقت ، بتقسيم البرنامج الصحيح إلى أجزاء ، يمكننا بسهولة إعادة استخدام هذه الأجزاء ، على وجه التحديد بسبب صحتها. أخيرًا ، في أي لغة مكدس ، يمكنك تحديد مجموعة فرعية من الأوامر التي تعمل فقط على الحالة الداخلية للجهاز (مكدس أو تسجيلات) ، وليس باستخدام أي ذاكرة خارجية. ستشكل هذه المجموعة الفرعية لغة لها خاصية التسلسل . في مثل هذه اللغة ، أي برنامج له معنى محول حالة الجهاز ، والتنفيذ المتسلسل للبرامج يعادل تكوينها ، مما يعني أنه أيضًا محول حالة.


يتم رؤية النمط العام: توليفة (تسلسل) البرامج الصحيحة تولد البرنامج الصحيح ، توليفة المحولات تولد المحول. اتضح أن برامج لغة المكدس مغلقة فيما يتعلق بعملية التسلسل أو تشكل بنية تسمى جرثومة أو الصهارة . هذا يعني أنه يمكنك ، عن طريق كتابة البرنامج على الشريط ، قطعه بشكل عشوائي تقريبًا ثم تشكيل برامج جديدة من الأجزاء الناتجة. علاوة على ذلك ، يمكنك قطع الأجزاء بتعليمات واحدة.


عند الترابط ، أمر مهم. على سبيل المثال ، يختلف هذان البرنامجان بلا شك:

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


ولكن لا يهم مكان قطع البرنامج ، إذا قمت بصقه على الفور في هذا المكان:

( texttt5dup)+ textttpop= texttt5+( textttduppop).


تعكس هذه الحقيقة البسيطة مدى سهولة عملية التسلسل وتنتقل بالبنية التي تشكلها برامج المكدس إلى مستوى جديد ، ونحن نفهم أن هذه مجموعة شبه .

وماذا يعطينا هذا كمبرمجين؟ يسمح لك Associativity بترجمة أقسام البرنامج المناسبة التعسفية وتحسينها وحتى موازنتها ، ثم دمجها في برنامج مكافئ. يمكننا تحمل إجراء تحليل ثابت لأي جزء من البرنامج واستخدامه في تحليل البرنامج بأكمله على وجه التحديد لأننا لا نهتم بمكان وضع الأقواس. هذه فرص مهمة وخطيرة للغاية للغة منخفضة المستوى أو لغة وسيطة لا يكتبها شخص ما ، بل مترجم. ومن وجهة نظر عالم رياضيات وعامل وظيفي مخضرم ، فإن هذا يجعل برامج تحويل حالة الآلة متكاملة. تشكل أشكال التشكل أيضًا مجموعة شبه مع عملية تكوين. في الجبر ، تسمى هذه الأشكال الداخلية مجموعات شبه التحويل فيما يتعلق ببعض المجموعات. على سبيل المثال ، تشكل آلات الحالة المحدودة مجموعة شبه تحويلية للعديد من الحالات.


يبدو "نصف المجموعة" فاترًا ، إلى حد ما أدنى. ربما برامج مكدس تشكل مجموعة ؟ آه ... لا ، معظم البرامج لا رجعة فيها ، أي ، وفقًا لنتائج التنفيذ ، لن يكون من الممكن استعادة البيانات الأصلية بشكل لا لبس فيه. لكن لدينا عنصر محايد. في لغات التجميع ، يتم الإشارة إليه  textttnop ولا يفعل أي شيء. إذا لم يتم تعريف عامل التشغيل هذا بشكل صريح في لغة المكدس ، فيمكن الحصول عليه بسهولة من خلال دمج بعض الأوامر ، على سبيل المثال:  textttincdec ،  textttduppop أو  textttمبادلةمبادلة . يمكن قطع هذه الأزواج بأمان من البرامج أو ، على العكس ، إدراجها في أي مكان بمبلغ تعسفي. نظرًا لوجود وحدة ، فإن برامجنا تشكل مجموعة شبه مع وحدة أو أحادية . لذلك ، يمكنك تنفيذها برمجيًا في شكل أحادي - أشكال داخلية على حالة الجهاز المكدس. سيسمح لك ذلك بتحديد مجموعة صغيرة من العمليات الأساسية للجهاز ، ثم إنشاء برامج باستخدام تركيبها ، والحصول على لغة مكدسة في شكل لغة خاصة بالمجال (EDSL) مضمنة.


في Haskell ، يتم وصف مجموعات شبه أحادية 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 :


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

نستخدم Maybe نوع ليس كما هو مستخدم عادة: قيمة فارغة Nothing تعني في الحالة أنه لا يوجد شيء خطير يحدث ، ويمكن متابعة الحساب ، بدوره ، تشير قيمة السلسلة إلى المشاكل. للراحة ، نحدد اثنين من منشئي المحتوى الذكية: أحدهما للبرامج التي تعمل فقط مع المكدس ، والآخر للذين يحتاجون إلى الذاكرة.


 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 ووظائف الوظائف إلى أن هذه البرامج ليست برامج قائمة بذاتها ، ولكنها مجمعات برامج: نهج نموذجي عند إنشاء 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 

لقد تحولت إلى 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]} 

في الواقع ، لم نفعل أي شيء جديد - من خلال الجمع بين محولات الاندماج ، عدنا بشكل أساسي إلى الالتفاف ، لكنه أصبح ضمنيًا. تذكر أن الالتفاف يوفر تجريدًا للمعالجة التسلسلية للبيانات الاستقرائية. يتم إنشاء البيانات ، في حالتنا ، حثيًا عندما يقوم المشغل بإلصاق البرامج  الماس ، ويتم "تخزينها" في الشكل الداخلي في شكل سلسلة من تركيبات وظائف تحويل الآلة حتى يتم تطبيق هذه السلسلة على الحالة الأولية. في حالة تفرعات branch while تبدأ السلسلة في التحول إلى شجرة أو حلقة. في الحالة العامة ، نحصل على رسم بياني يعكس تشغيل جهاز آلي بذاكرة تخزين ، أي آلة مكدسة. هذه هي البنية التي "ننهار" أثناء تنفيذ البرنامج.


ما مدى فعالية هذا التنفيذ؟ تكوين الوظائف هو أفضل ما يمكن أن يفعله مترجم Haskell. لقد ولد حرفيا لهذا! عندما يتعلق الأمر بفوائد استخدام المعرفة بالأحاديات ، فإنهم غالبًا ما يقدمون مثالًا لقوائم الاختلاف 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 = () 

مع عملية الضرب ، تشكل المجموعات شبه نفسها مجموعة نصف ، ومع مراعاة نوع الوحدة ، يمكننا القول أن الأحاديات تشكل أحادية! يتم تحقيق توحدية وحيادية الوحدة حتى التماثل ، ولكن هذا ليس مهمًا.


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 monad ، وهو مجرد وظيفة.


سنقدم سجلًا في هيكل الجهاز ، ولكننا لن نربطه بأي نوع معين ، ولكن نخرجه إلى معلمة النوع. سنكتب للمجلة باستخدام العملية الأحادية العامة.


 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 

. , , . .


, — , . , . :

a r i t y ( add ) = 2 1


فيما يلي التكافؤ لبعض المشغلين الآخرين:

a r i t y ( push ) = 0 1a r i t y ( pop ) = 1 0a r i t y ( exch ) = 2 3


لماذا نقوم بالحجز في كل وقت: الحد الأدنى لعدد الحد الأقصى للمتطلبات ..؟ والحقيقة هي أن جميع المشغلين الأساسيين لديهم تكافؤ محدد بدقة ، ولكن عند التفرع ، يمكن أن يكون للفروع المختلفة متطلبات ونتائج مختلفة. مهمتنا: لحساب المتطلبات الأكثر صرامة التي يجب أن تضمن تشغيل جميع الفروع ، بغض النظر عن عددها.

في التنفيذ المتسلسل لأوامر التكافؤ يتم دمجها بالطريقة غير التقليدية التالية:

(i1o1)(i2o2)=(a+i1)(a+o1+o2i2),a=max(0,i2o1).


هذه العملية جماعية ولها عنصر محايد ، وهو ليس مفاجئًا لمقال عن monoids. أضف هذه النتيجة إلى البرنامج:
 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 , , — , , . , , . — ! , . , - . ( -) , . — ! "" , , , , . , , .




. - , . — , . .

Source: https://habr.com/ru/post/ar429530/


All Articles