Empileuse monoïde

Il n'y a pas si longtemps, un article excellent et inspirant sur les compilateurs et les machines empilées est paru sur Habré. Il montre le chemin d'une simple implémentation d'un exécuteur de bytecode à des versions de plus en plus performantes. Je voulais montrer sur l'exemple du développement d'une machine empilée comment cela peut être fait à la manière de Haskell.

En utilisant l'exemple du langage pour une machine empilée, nous verrons comment le concept mathématique des semi-groupes et des monoïdes aide à développer et à étendre l'architecture du programme, comment utiliser l'algèbre monoïde et comment construire des programmes sous la forme d'un ensemble d'homomorphismes entre les systèmes algébriques. Comme exemples de travail, nous construisons d'abord un interpréteur inséparable du code sous la forme d'EDSL, puis nous lui enseignons différentes choses: enregistrer des informations de débogage arbitraires, séparer le code du programme du programme lui-même, effectuer une analyse statique simple et le calculer avec divers effets.

L'article est destiné à ceux qui connaissent la langue Haskell à un niveau intermédiaire et supérieur, à ceux qui l'utilisent déjà dans le travail ou la recherche, et à tous les curieux qui ont jeté un coup d'œil pour voir ce que les fonctionnaires n'ont pas encore fait. Eh bien, pour ceux, bien sûr, que le paragraphe précédent n'a pas effrayé.

Il s'est avéré beaucoup de matériel, avec de nombreux exemples dans le code, et pour que le lecteur comprenne plus facilement s'il doit y plonger, je donnerai un contenu annoté.

Les tâches de traduction et d'interprétation fournissent de nombreux exemples intéressants et utiles pour démontrer les aspects les plus divers de la programmation. Ils vous permettent d'aller à différents niveaux de complexité et d'abstraction, tout en restant assez pratiques. Dans cet article, nous nous concentrerons sur la démonstration des capacités de deux structures mathématiques importantes - un semi - groupe et un monoïde . Elles ne sont pas discutées aussi souvent que les monades ou les objectifs, et elles ne font pas peur aux petits programmeurs, ces structures sont beaucoup plus faciles à comprendre, mais pour autant, elles sous-tendent la programmation fonctionnelle. La maîtrise virtuose des types monoïdes, démontrée par les professionnels, admire la simplicité et l'élégance des solutions.

Une recherche du mot "monoïde" dans les articles sur Habré ne fait pas plus de quatre douzaines d'articles (sur les mêmes monades, par exemple, il y en a trois cents). Ils commencent tous conceptuellement par quelque chose comme: un monoïde est tellement ... et ensuite, avec un enthousiasme tout à fait compréhensible, ils énumèrent ce qu'est un monoïde - des lignes aux arbres à doigts, des analyseurs d'expression régulière à Dieu sait quoi d'autre ! Mais en pratique, nous pensons dans l'ordre inverse: nous avons un objet qui doit être modélisé, nous analysons ses propriétés et constatons qu'il a les signes de l'une ou l'autre structure abstraite, nous décidons: avons-nous besoin des conséquences de cette circonstance et comment l'utilisons-nous. Nous allons suivre cette voie. Et en même temps, nous ajouterons quelques exemples intéressants à la collection de monoïdes utiles.

Langues et programmes pour les machines à pile

Les machines à pile dans l'étude de la programmation fonctionnelle apparaissent généralement au moment où elles abordent le concept de convolution. Dans ce cas, une implémentation extrêmement concise de l'exécuteur du calculateur de pile le plus simple est donnée, par exemple, ceci:

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

Bon début de conversation! Ensuite, en règle générale, ils commencent à attacher des effets: ils changent la convolution de foldM en foldM , fournissent la totalité via la monade Either String , puis ajoutent la journalisation, enveloppant tout avec le transformateur WriterT , implémentent le dictionnaire StateT pour les variables, etc. Parfois, pour démontrer la fraîcheur des calculs monadiques, ils implémentent une calculatrice ambiguë qui renvoie toutes les valeurs possibles de l'expression $$$(14 \ pm 3) * ((16 \ pm 8) \ pm 5)$ . C'est une conversation longue, bonne et intéressante. Cependant, nous allons immédiatement mener notre histoire d'une manière différente, bien que nous la terminions avec le même résultat.

Pourquoi, en général, s'agit-il de pliage? Parce que la convolution (catamorphisme) est une abstraction du traitement séquentiel des données inductives . La machine de pile parcourt linéairement le code, exécute une séquence d'instructions et génère une valeur - l'état de la pile. J'aime imaginer le travail d'une machine à pile convolutionnelle comme traduisant l'ARN matriciel dans une cellule vivante. Le ribosome parcourt pas à pas toute la chaîne d'ARN, compare les triplets de nucléotides aux acides aminés et crée la structure primaire de la protéine.

La machine à convolution a un certain nombre de limitations, l'essentiel est que le programme soit toujours lu du début à la fin et une fois. Les appels de branchement, de boucles et de sous-programmes nécessitent une modification conceptuelle de l'interpréteur. Rien de compliqué, bien sûr, mais une telle machine ne peut plus être décrite par une simple convolution.

Selon l'hypothèse de la relativité linguistique, les propriétés de la langue que nous utilisons affectent directement les propriétés de notre pensée. Faisons attention non pas à la machine, mais aux langages et programmes qu'elle contrôle.

Tous les langages orientés pile, à la fois relativement bas niveau (bytecodes de machines virtuelles Java et Python ou .NET) et les langages de niveau supérieur (PostScript, Forth ou Joy), ont une propriété commune fondamentale: si vous écrivez deux programmes corrects en séquence, alors obtenir le bon programme. Certes, correct ne signifie pas «correct», ce programme peut se bloquer avec des erreurs sur toutes les données ou échouer dans des cycles sans fin et n'a aucun sens, mais l'essentiel est qu'un tel programme puisse être exécuté par la machine. Dans le même temps, en divisant le programme correct en parties, nous pouvons facilement réutiliser ces parties, précisément en raison de leur exactitude. Enfin, dans n'importe quel langage de pile, vous pouvez sélectionner un sous-ensemble de commandes qui fonctionnent uniquement sur l'état interne de la machine (pile ou registres), sans utiliser de mémoire externe. Ce sous-ensemble formera un langage avec la propriété de concaténation . Dans un tel langage, tout programme a la signification d'un convertisseur d'état machine, et l'exécution séquentielle des programmes est équivalente à leur composition, ce qui signifie qu'il s'agit également d'un convertisseur d'état.

On observe le schéma général: la combinaison (concaténation) des bons programmes génère le bon programme, la combinaison des convertisseurs génère le convertisseur. Il s'avère que les programmes de langage de pile sont fermés par rapport à l'opération de concaténation ou forment une structure appelée groupoïde ou magma . Cela signifie que vous pouvez, en écrivant le programme sur une bande, le couper presque aléatoirement, puis former de nouveaux programmes à partir des segments résultants. De plus, vous pouvez découper en segments avec une seule instruction.

Lors du collage, l'ordre est important. Par exemple, ces deux programmes sont sans aucun doute différents:

Et qu'est-ce que cela nous donne en tant que programmeurs? L'associativité vous permet de précompiler, d'optimiser et même de paralléliser des sections de programme arbitraires appropriées pour cela, puis de les combiner en un programme équivalent. Nous pouvons nous permettre d'effectuer une analyse statique de n'importe quelle partie du programme et de l'utiliser dans l'analyse de l'ensemble du programme précisément parce que nous ne nous soucions pas où placer les crochets. Ce sont des opportunités très importantes et sérieuses pour une langue de bas niveau ou une langue intermédiaire dans laquelle pas une personne écrit, mais un traducteur. Et du point de vue d'un mathématicien et d'un travailleur fonctionnel chevronné, cela rend les programmes de conversion d'état de la machine endomorphismes à part entière. Les endomorphismes forment également un semi-groupe avec une opération de composition. En algèbre, ces endomorphismes sont appelés semi-groupes de transformation par rapport à un ensemble. Par exemple, les machines à états finis forment un semi-groupe de transformation de nombreux états.

«Semigroup» semble timide, en quelque sorte inférieur. Peut-être que les programmes de pile forment un groupe ? Euh ... non, la plupart des programmes sont irréversibles, c'est-à-dire qu'en fonction du résultat de l'exécution, il ne sera pas possible de restaurer sans ambiguïté les données d'origine. Mais nous avons un élément neutre. Dans les langages d'assemblage, il est noté $$$\ texttt {nop}$ et ne fait rien. Si un tel opérateur n'est pas explicitement défini dans le langage de pile, il peut être facilement obtenu en combinant certaines commandes, par exemple: $$$\ texttt {inc dec}$ , $$$\ texttt {dup pop}$ ou $$$\ texttt {swap swap}$ . De telles paires peuvent être coupées en toute sécurité des programmes ou, au contraire, insérées n'importe où dans une quantité arbitraire. Puisqu'il y a une unité, nos programmes forment un semi - groupe avec une unité ou un monoïde . Ainsi, vous pouvez les implémenter par programme sous forme de monoïdes - endomorphismes sur l'état de la machine empilée. Cela vous permettra de définir un petit ensemble d'opérations de base pour la machine, puis de créer des programmes en utilisant leur composition, obtenant un langage empilé sous la forme d'un langage spécifique au domaine intégré (EDSL).

À Haskell, les semi-groupes et les monoïdes sont décrits à l'aide des Monoid semi-groupe et Monoid . Leurs définitions sont simples et ne reflètent que la structure de base, les exigences d'associativité et de neutralité doivent être vérifiées par le programmeur:

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

Construire une voiture

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

Nous allons immédiatement construire une machine qui a une pile, une mémoire finie et qui peut s'arrêter d'urgence de manière correcte et propre. Tout cela est réalisé sans l'utilisation de monades, encapsulant les données nécessaires dans un type qui décrit la machine. Ainsi, tous les programmes de base, et donc toutes leurs combinaisons, seront de purs convertisseurs de son état.

Commençons par définir le type de la machine virtuelle et les fonctions de définition triviales.

 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 

Les setters sont nécessaires pour rendre la sémantique du programme explicite. Par processeur (type Processor ), nous entendons le convertisseur VM -> VM .

Maintenant, nous définissons les types de wrapper pour le monoïde de transformation et pour le programme:

 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) 

Les types de wrapper déterminent le principe de combinaison des programmes: ce sont des endomorphismes avec l'ordre inverse de la composition (de gauche à droite). L'utilisation de wrappers permet au compilateur de déterminer indépendamment comment le type de Program implémente les exigences des Monoid Semigroup et Monoid .

L'exécuteur du programme est trivial:

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

Le message d'erreur sera généré par la fonction err :

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

Nous utilisons le type Maybe pas comme il est habituellement utilisé: une valeur Nothing vide dans le statut signifie que rien de dangereux ne se produit, et le calcul peut être poursuivi, à son tour, la valeur de chaîne signifie des problèmes. Pour plus de commodité, nous définissons deux constructeurs intelligents: l'un pour les programmes qui fonctionnent uniquement avec la pile, et l'autre pour ceux qui ont besoin de mémoire.

 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 

Vous pouvez maintenant définir des commandes de langage de base pour travailler avec la pile et la mémoire, l'arithmétique entière, ainsi que les relations d'équivalence et d'ordre.

 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) 

Les ramifications et les boucles ne suffisent pas pour un travail à part entière. En fait, pour le langage embarqué, seule la ramification est suffisante, les boucles peuvent être organisées en utilisant la récursivité dans le langage hôte (en Haskell), mais nous rendrons notre langage autosuffisant. De plus, nous profitons du fait que les programmes forment un semi-groupe et déterminons le combinateur de la répétition du programme le nombre de fois spécifié. Il prendra le nombre de répétitions de la pile.

 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 

Les types des fonctions branch et while indiquent qu'il ne s'agit pas de programmes autonomes, mais de combinateurs de programmes: une approche typique lors de la création d'EDSL dans Haskell. La fonction stimes définie pour tous les semi-groupes; elle renvoie la composition du nombre spécifié d'éléments.

Enfin, nous écrirons quelques programmes d'expériences.

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

Il s'est avéré 120 lignes de code avec des commentaires et des annotations de types qui définissent une machine qui fonctionne avec 18 commandes avec trois combinateurs. Voilà comment fonctionne notre voiture.

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

En fait, nous n'avons rien fait de nouveau - en combinant des convertisseurs d'endomorphisme, nous sommes essentiellement revenus à la convolution, mais elle est devenue implicite. Rappelons que la convolution fournit une abstraction du traitement séquentiel des données inductives. Les données, dans notre cas, sont générées par induction lorsque l'opérateur colle les programmes $$$\ diamant$ , et ils sont "stockés" dans l'endomorphisme sous la forme d'une chaîne de compositions de fonctions de transformation machine jusqu'à ce que cette chaîne soit appliquée à l'état initial. Dans le cas des combinateurs de branch et while chaîne commence à se transformer en arbre ou en boucle. Dans le cas général, nous obtenons un graphique reflétant le fonctionnement d'un automate avec mémoire de stockage, c'est-à-dire une machine empilée. C'est cette structure que nous «effondrons» lors de l'exécution du programme.

Quelle est l'efficacité de cette mise en œuvre? La composition des fonctions est la meilleure que le compilateur Haskell puisse faire. Il est littéralement né pour ça! En ce qui concerne les avantages de l'utilisation de la connaissance des monoïdes, ils donnent souvent un exemple de listes de différences diffList - implémentant une liste liée sous la forme d'une composition d'endomorphismes. Les listes de différences accélèrent fondamentalement la formation de listes à partir de nombreuses pièces en raison de l'associativité de la composition des fonctions. S'attaquer aux types de wrapper n'entraîne pas une augmentation des frais généraux, ils "se dissolvent" au stade de la compilation. Du travail supplémentaire, seule une vérification de l'état reste à chaque étape du programme.

Combiner des monoïdes

Je pense qu'à ce moment, les sceptiques et les lecteurs occasionnels nous ont déjà quittés, vous pouvez vous permettre de vous détendre et passer au niveau d'abstraction suivant.

Le concept de semi-groupes et de monoïdes ne serait pas aussi utile et universel, sinon pour une série de propriétés inhérentes à tous les semi-groupes et monoïdes sans exception, qui nous permettent de construire des structures complexes à partir de structures simples de la même manière que nous construisons des programmes complexes à partir de simples. Ces propriétés ne s'appliquent plus aux objets, mais aux types, et il vaut mieux les écrire non pas en notation mathématique, mais sous forme de programmes en Haskell, qui, grâce à l'isomorphisme de Curry-Howard, en sont la preuve.

1) Les monoïdes et les semi-groupes peuvent être "multipliés". Il s'agit du produit de types dont l'abstraction dans Haskell est un tuple ou une paire.

 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) Il y a un seul monoïde, il est représenté par un seul type () :

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

Avec l'opération de multiplication, les semi-groupes eux-mêmes forment un semi-groupe, et compte tenu du type d'unité, on peut dire que les monoïdes forment un monoïde! L'associativité et la neutralité d'une unité sont remplies jusqu'à l'isomorphisme, mais ce n'est pas important.

3) Mappages dans un semi-groupe ou une forme monoïde, respectivement, un semi-groupe ou un monoïde. Et ici, il est également plus facile d'écrire cette déclaration dans Haskell:

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

Nous utiliserons ces combinateurs pour étendre les capacités du langage de pile que nous avons construit. Faisons un changement majeur et faisons nos fonctions de commandes de base qui retournent des programmes . Cela ne les privera pas de leurs propriétés monoïdes, mais permettra d'entrer des informations arbitraires de l'extérieur dans le travail de toutes les commandes de la machine. Voici ce que cela signifie:

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

Les informations peuvent être n'importe quel, par exemple, un dictionnaire externe avec quelques définitions, ou un moyen de garder un journal des calculs nécessaires pendant le débogage. Ceci est très similaire à l'action du Reader monade, qui, juste, n'est qu'une fonction.

Nous allons introduire un journal dans la structure de la machine, mais nous ne le lierons pas à un type particulier, mais le publierons dans le paramètre type. Nous écrirons au journal en utilisant l'opération monoïdale généralisée.

 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 

Désormais, nous nous permettons de ne pas spécifier d'annotations de type pour toutes les définitions, laissant le compilateur les traiter indépendamment, elles ne sont pas compliquées, bien qu'elles deviennent lourdes. Les équipes elles-mêmes n'auront pas à être changées, grâce à des designers intelligents qui s'occuperont de tous les changements. Assez petit.

 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 

Il reste à apprendre à saisir des informations externes dans l'exécuteur du programme. C'est très facile à faire en créant différents artistes avec différentes stratégies de journalisation. Le premier interprète sera l'effort le plus simple, le plus silencieux et le plus efficace pour tenir un journal:

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

Ici, un seul monoïde () été utile - un élément neutre dans l'algèbre monoïde. De plus, il est possible de définir une fonction pour un exécuteur qui est prêt à enregistrer telle ou telle information sur l'état de la machine dans le journal.

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

Les informations peuvent être, par exemple, telles que:

 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 

. , , . .

, — , . , . :

Lors de l'exécution séquentielle des commandes de valence, elles sont combinées de la manière non triviale suivante:

 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 

Et puis vous pouvez construire un homomorphisme:

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

. - , . — , . .