Empilhador monóide

Há pouco tempo, um artigo excelente e inspirador sobre compiladores e máquinas empilhadas apareceu em Habré. Ele mostra o caminho da implementação simples de um executor de bytecode para versões cada vez mais eficientes. Eu queria mostrar no exemplo do desenvolvimento de uma máquina empilhada como isso pode ser feito da maneira Haskell.

Usando a interpretação da linguagem para uma máquina empilhada como exemplo, veremos como o conceito matemático de semigrupos e monoides ajuda a desenvolver e expandir a arquitetura do programa, como usar a álgebra monóide e como construir programas na forma de um conjunto de homomorfismos entre sistemas algébricos. Como exemplos de trabalho, primeiro construímos um intérprete que é inseparável do código na forma de EDSL e depois ensinamos coisas diferentes: registre informações arbitrárias de depuração, separe o código do programa do próprio programa, realize análises estáticas simples e calcule-o com vários efeitos.

O artigo é destinado àqueles que falam a língua Haskell em um nível intermediário e acima, para aqueles que já a usam em trabalho ou pesquisa e para todos os curiosos que olharam para ver o que os funcionários distorceram. Bem, para aqueles, é claro, a quem o parágrafo anterior não assustou.

Ele revelou muito material, com muitos exemplos no código, e para tornar mais fácil para o leitor entender se ele precisa mergulhar nele, darei conteúdo anotado.

As tarefas de tradução e interpretação fornecem muitos exemplos interessantes e úteis para demonstrar os mais diversos aspectos da programação. Eles permitem que você vá para diferentes níveis de complexidade e abstração, mantendo-se bastante prático. Neste artigo, focaremos na demonstração das capacidades de duas importantes estruturas matemáticas - um semigrupo e um monóide . Eles não são discutidos com a mesma frequência que mônadas ou lentes, e não assustam pequenos programadores, essas estruturas são muito mais fáceis de entender, mas, apesar disso, estão subjacentes à programação funcional. O domínio virtuoso dos tipos monoidais, demonstrado por profissionais, admira a simplicidade e a elegância das soluções.

A busca pela palavra "monóide" em artigos sobre Habré não publica mais de quatro dúzias de artigos (sobre as mesmas mônadas, por exemplo, existem trezentas). Todos eles conceitualmente começam com algo como: um monóide é tantos ... e então, com entusiasmo compreensível, eles listam o que é um monóide - das linhas às árvores dos dedos, dos analisadores de expressões regulares a Deus sabe o que mais ! Mas, na prática, pensamos na ordem oposta: temos um objeto que precisa ser modelado, analisamos suas propriedades e descobrimos que ele tem os sinais de uma ou outra estrutura abstrata, decidimos: precisamos de consequências dessa circunstância e como a usamos. Nós vamos por esse caminho. E, ao mesmo tempo, adicionaremos alguns exemplos interessantes à coleção de monoides úteis.

Idiomas e programas para máquinas de empilhar

As máquinas de empilhamento no estudo da programação funcional geralmente aparecem no momento em que abordam o conceito de convolução. Nesse caso, é fornecida uma implementação extremamente concisa do executor da calculadora de pilha mais simples, por exemplo:

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

Ótimo começo para a conversa! Então, como regra geral, eles começam a anexar efeitos: eles alteram a convolução foldM para foldM , fornecem totalidade através da mônada Either String e adicionam log, envolvendo tudo com o transformador WriterT , implementam o dicionário StateT para variáveis ​​e assim por diante. Às vezes, para demonstrar a frieza dos cálculos monádicos, eles implementam uma calculadora ambígua que retorna todos os valores possíveis da expressão $$$(2 \ pm 3) * ((16 \ 8) \ pm 5)$ . Esta é uma conversa longa, boa e interessante. No entanto, lideraremos imediatamente nossa história de uma maneira diferente, embora a terminemos com o mesmo resultado.

Por que, em geral, é sobre dobrar? Porque a convolução (catamorfismo) é uma abstração do processamento seqüencial de dados indutivos . A máquina da pilha é executada linearmente pelo código, executando uma sequência de instruções e gera um valor - o estado da pilha. Eu gosto de imaginar o trabalho de uma máquina de pilha convolucional como a tradução do RNA da matriz em uma célula viva. O ribossomo percorre toda a cadeia de RNA passo a passo, compara os trigêmeos de nucleotídeos com aminoácidos e cria a estrutura primária da proteína.

A máquina de convolução tem várias limitações, o principal é que o programa seja sempre lido do começo ao fim e uma vez. Ramificações, loops e chamadas de sub-rotina requerem uma alteração conceitual no intérprete. Nada complicado, é claro, mas essa máquina não pode mais ser descrita por uma simples convolução.

De acordo com a hipótese da relatividade linguística, as propriedades da linguagem que usamos afetam diretamente as propriedades do nosso pensamento. Vamos prestar atenção não à máquina, mas às linguagens e programas que ela controla.

Todas as linguagens orientadas a pilha, tanto de nível relativamente baixo (códigos de máquinas virtuais Java e Python ou .NET) quanto as de nível superior (PostScript, Forth ou Joy), têm uma propriedade comum fundamental: se você escrever dois programas corretos em sequência, então obtenha o programa correto. Verdadeiro, correto não significa "correto", este programa pode travar com erro em qualquer dado ou falhar em ciclos intermináveis ​​e não faz sentido algum, mas o principal é que esse programa possa ser executado pela máquina. Ao mesmo tempo, dividindo o programa correto em partes, podemos reutilizá-las facilmente, precisamente por causa de sua correção. Por fim, em qualquer idioma da pilha, você pode selecionar um subconjunto de comandos que operam apenas no estado interno da máquina (pilha ou registradores), sem usar nenhuma memória externa. Esse subconjunto formará um idioma com a propriedade de concatenação . Nesse idioma, qualquer programa tem o significado de um conversor de estado da máquina e a execução sequencial de programas é equivalente à sua composição, o que significa que também é um conversor de estado.

O padrão geral está sendo visto: a combinação (concatenação) dos programas corretos gera o programa correto, a combinação de conversores gera o conversor. Acontece que os programas de linguagem de pilha são fechados com relação à operação de concatenação ou formam uma estrutura chamada groupoide ou magma . Isso significa que você pode, gravando o programa em fita, cortá-lo quase aleatoriamente e formar novos programas a partir dos segmentos resultantes. Além disso, você pode cortar segmentos com uma única instrução.

Na ligação, a ordem é importante. Por exemplo, esses dois programas são indiscutivelmente diferentes:

E o que isso nos dá como programadores? A associatividade permite pré-compilar, otimizar e até paralelizar seções de programas arbitrárias adequadas para isso e combiná-las em um programa equivalente. Podemos nos dar ao luxo de realizar uma análise estática de qualquer parte do programa e usá-la na análise de todo o programa precisamente porque não nos importamos onde colocar os colchetes. Essas são oportunidades muito importantes e sérias para um idioma de baixo nível ou intermediário, no qual não uma pessoa escreve, mas um tradutor. E do ponto de vista de um matemático e de um trabalhador funcional experiente, isso faz com que os programas de conversão de estado da máquina desenvolvam endomorfismos completos. Endomorfismos também formam um semigrupo com uma operação de composição. Na álgebra, esses endomorfismos são chamados semigrupos de transformação em relação a algum conjunto. Por exemplo, máquinas de estados finitos formam um semigrupo de transformação de muitos estados.

"Semigrupo" soa sem entusiasmo, de alguma forma inferior. Talvez os programas de pilha formem um grupo ? Uh ... não, a maioria dos programas é irreversível, ou seja, de acordo com o resultado da execução, não será possível restaurar inequivocamente os dados originais. Mas temos um elemento neutro. Em linguagens assembly, é indicado $$$\ texttt {nop}$ e não faz nada. Se esse operador não estiver definido explicitamente na linguagem da pilha, ele poderá ser obtido facilmente combinando alguns comandos, por exemplo: $$$\ texttt {inc dec}$ , $$$\ texttt {pop-up duplicado}$ ou $$$\ texttt {swap swap}$ . Esses pares podem ser cortados com segurança de programas ou, pelo contrário, inseridos em qualquer lugar em um valor arbitrário. Como existe uma unidade, nossos programas formam um semigrupo com uma unidade ou monóide . Assim, você pode implementá-los programaticamente na forma de monóides - endomorfismos sobre o estado da máquina empilhada. Isso permitirá que você defina um pequeno conjunto de operações básicas para a máquina e crie programas usando sua composição, obtendo uma linguagem empilhada na forma de uma linguagem específica de domínio incorporada (EDSL).

Em Haskell, semigrupos e monoides são descritos usando as Monoid Semigroup e Monoid . Suas definições são simples e refletem apenas a estrutura básica, os requisitos de associatividade e neutralidade devem ser verificados pelo programador:

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

Construindo um carro

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

Construiremos imediatamente uma máquina que tenha uma pilha, uma memória finita e possa parar de emergência de uma maneira boa e limpa. Tudo isso é realizado sem o uso de mônadas, encapsulando os dados necessários em um tipo que descreve a máquina. Assim, todos os programas básicos e, portanto, todas as suas combinações, serão puros conversores de seu estado.

Vamos começar definindo o tipo da máquina virtual e as funções triviais do setter.

 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 

Setters são necessários para tornar a semântica do programa explícita. Por processador (tipo Processor ) queremos dizer o conversor VM -> VM .

Agora, definimos os tipos de wrapper para o monóide de transformação e para o programa:

 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) 

Os tipos de invólucro determinam o princípio da combinação de programas: são endomorfismos com a ordem inversa da composição (da esquerda para a direita). O uso de wrappers permite que o compilador determine independentemente como o tipo de Program implementa os requisitos das Monoid Semigroup e Monoid .

O executor do programa é trivial:

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

A mensagem de erro será gerada pela função err :

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

Usamos o tipo Maybe não como é normalmente usado: um valor Nothing vazio no status significa que nada de perigoso está acontecendo, e o cálculo pode ser continuado, por sua vez, o valor da string significa problemas. Por conveniência, definimos dois construtores inteligentes: um para programas que funcionam apenas com a pilha e outro para aqueles que precisam de memória.

 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 

Agora você pode definir comandos básicos de linguagem para trabalhar com a pilha e a memória, aritmética de número inteiro e também relações de equivalência e ordem.

 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) 

Ramificações e loops não são suficientes para um trabalho completo. Na verdade, para o idioma incorporado, apenas a ramificação é suficiente, os loops podem ser organizados usando a recursão no idioma host (em Haskell), mas tornaremos nosso idioma auto-suficiente. Além disso, aproveitamos o fato de os programas formarem um semigrupo e determinamos o combinador da repetição do programa o número especificado de vezes. Ele pegará o número de repetições da pilha.

 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 

Os tipos de funções branch e while indicam que esses não são programas independentes, mas combinadores de programas: uma abordagem típica ao criar EDSL em Haskell. A função stimes definida para todos os semigrupos; retorna a composição do número especificado de elementos.

Por fim, escreveremos alguns programas para experimentos.

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

Foram produzidas 120 linhas de código com comentários e anotações de tipos que definem uma máquina que opera com 18 comandos com três combinadores. É assim que o nosso carro funciona.

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

De fato, não fizemos nada de novo - combinando conversores de endomorfismo, voltamos essencialmente à convolução, mas ela se tornou implícita. Lembre-se de que a convolução fornece uma abstração do processamento seqüencial de dados indutivos. Os dados, no nosso caso, são gerados indutivamente quando o operador cola os programas $$$\ diamante$ , e eles são "armazenados" no endomorfismo na forma de uma cadeia de composições de funções de transformação de máquinas até que essa cadeia seja aplicada ao estado inicial. No caso dos combinadores branch e while cadeia começa a se transformar em uma árvore ou um loop. No caso geral, obtemos um gráfico refletindo a operação de um autômato com memória de armazenamento, ou seja, uma máquina empilhada. É essa estrutura que "colapsamos" durante a execução do programa.

Qual é a eficácia dessa implementação? A composição de funções é a melhor que o compilador Haskell pode fazer. Ele nasceu literalmente para isso! Quando se trata dos benefícios do uso do conhecimento de monóides, eles geralmente dão um exemplo de diffList listas de diferenças - implementando uma lista vinculada como uma composição de endomorfismos. As listas de diferenças aceleram fundamentalmente a formação de listas de várias partes devido à associatividade da composição de funções. A confusão com os tipos de invólucro não leva a um aumento na sobrecarga, eles "se dissolvem" no estágio de compilação. Do trabalho extra, apenas uma verificação de status permanece em cada etapa do programa.

Combinar Monoids

Penso que, neste momento, céticos e leitores casuais já nos deixaram, você pode relaxar e passar para o próximo nível de abstração.

O conceito de semigrupos e monoides não seria tão útil e universal, se não fosse por uma série de propriedades inerentes a todos os semigrupos e monoides sem exceção, que nos permitem construir estruturas complexas a partir de estruturas simples da mesma maneira que criamos programas complexos a partir de simples. Essas propriedades não se aplicam mais a objetos, mas a tipos, e é melhor escrevê-las não em notação matemática, mas na forma de programas em Haskell, que, em virtude do isomorfismo de Curry-Howard, são suas provas.

1) Monoides e semigrupos podem ser "multiplicados". Isso se refere ao produto dos tipos, cuja abstração em Haskell é uma tupla ou par.

 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) Existe um único monóide, é representado por um único tipo () :

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

Com a operação de multiplicação, os próprios semigrupos formam um semigrupo e, levando em consideração o tipo de unidade, podemos dizer que os monoides formam um monóide! A associatividade e a neutralidade de uma unidade são cumpridas até o isomorfismo, mas isso não é importante.

3) Mapeamentos para uma forma semigrupo ou monóide, respectivamente, semigrupo ou monóide. E aqui também é mais fácil escrever essa declaração em Haskell:

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

Usaremos esses combinadores para expandir os recursos da linguagem de pilha que construímos. Vamos fazer uma grande mudança e fazer nossas funções básicas de comandos que retornam programas . Isso não os privará de suas propriedades monoidais, mas permitirá inserir informações arbitrárias de fora para o trabalho de todos os comandos da máquina. Aqui está o que se entende:

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

As informações podem ser qualquer, por exemplo, um dicionário externo com algumas definições ou uma maneira de manter um registro dos cálculos necessários durante a depuração. Isso é muito semelhante à ação do Reader mônada, que, apenas, é apenas uma função.

Introduziremos um log na estrutura da máquina, mas não o vincularemos a nenhum tipo específico, mas o enviaremos ao parâmetro type. Escreveremos para o diário usando a operação monoidal generalizada.

 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 

A partir de agora, nos permitimos não especificar anotações de tipo para todas as definições, deixando o compilador lidar com elas independentemente, elas não são complicadas, embora se tornem complicadas. As próprias equipes não precisarão ser alteradas, graças a designers inteligentes que cuidarão de todas as mudanças. Muito pequeno.

 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 

Resta ensinar a inserir informações externas no executor do programa. Isso é muito fácil, criando artistas diferentes com diferentes estratégias de registro. O primeiro artista será o mais simples, mais silencioso, e não desperdiçará esforços para manter um diário:

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

Aqui, um único monóide () foi útil para nós - um elemento neutro na álgebra monóide. Além disso, é possível definir uma função para um executor que esteja pronto para registrar esta ou aquela informação sobre o estado da máquina no diário.

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

As informações podem ser, por exemplo:

 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 

. , , . .

, — , . , . :

Ao executar comandos de valência sequencialmente, eles são combinados da seguinte maneira não trivial:

 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 

E então você pode construir um homomorfismo:

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

. - , . — , . .