Apiladora monoide

No hace mucho tiempo, apareció en Habré un excelente e inspirador artículo sobre compiladores y máquinas apiladas. Muestra el camino desde una implementación simple de un ejecutor de código de bytes hasta versiones cada vez más eficientes. Quería mostrar en el ejemplo del desarrollo de una máquina apilada cómo se puede hacer esto en Haskell-way.

Usando la interpretación del lenguaje para una máquina apilada como ejemplo, veremos cómo el concepto matemático de semigrupos y monoides ayuda a desarrollar y expandir la arquitectura del programa, cómo usar el álgebra monoide y cómo construir programas en forma de un conjunto de homomorfismos entre sistemas algebraicos. Como ejemplos de trabajo, primero creamos un intérprete que es inseparable del código en forma de EDSL, y luego le enseñamos cosas diferentes: registrar información de depuración arbitraria, separar el código del programa del propio programa, realizar análisis estáticos simples y calcularlo con varios efectos.

El artículo está dirigido a aquellos que conocen el idioma Haskell en un nivel intermedio y superior, para aquellos que ya lo usan en el trabajo o la investigación, y para todos los curiosos que han echado un vistazo para ver lo que los funcionarios aún tienen que hacer. Bueno, para aquellos, por supuesto, a quienes el párrafo anterior no asustó.

Resultó una gran cantidad de material, con muchos ejemplos en el código, y para que sea más fácil para el lector entender si necesita sumergirse en él, daré contenido anotado.

Las tareas de traducción e interpretación proporcionan muchos ejemplos interesantes y útiles para demostrar los aspectos más diversos de la programación. Le permiten ir a diferentes niveles de complejidad y abstracción, sin dejar de ser bastante práctico. En este artículo, nos centraremos en demostrar las capacidades de dos estructuras matemáticas importantes: un semigrupo y un monoide . No se discuten con tanta frecuencia como las mónadas o las lentes, y no asustan a los pequeños programadores, estas estructuras son mucho más fáciles de entender, pero por todo eso, subyacen a la programación funcional. El dominio virtuoso de los tipos monoidales, demostrado por profesionales, admira la simplicidad y la elegancia de las soluciones.

La búsqueda de la palabra "monoide" en artículos sobre Habré no emite más de cuatro docenas de artículos (sobre las mismas mónadas, por ejemplo, hay trescientas de ellas). Conceptualmente, todos comienzan con algo como: un monoide es tantos ... y luego, con un entusiasmo bastante comprensible, enumeran lo que es un monoide: desde líneas hasta árboles de dedos, desde analizadores de expresiones regulares hasta Dios sabe qué más . Pero en la práctica, pensamos en el orden opuesto: tenemos un objeto que necesita ser modelado, analizamos sus propiedades y encontramos que tiene los signos de una u otra estructura abstracta, decidimos: ¿necesitamos consecuencias de esta circunstancia y cómo la usamos? Nosotros iremos por este camino. Y al mismo tiempo agregaremos un par de ejemplos interesantes a la colección de monoides útiles.

Idiomas y programas para máquinas apiladoras

Las máquinas apiladoras en el estudio de la programación funcional generalmente aparecen en el momento en que se acercan al concepto de convolución. En este caso, se da una implementación extremadamente concisa del ejecutor de la calculadora de pila más simple, por ejemplo, esto:

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

Gran comienzo de la conversación! Luego, como regla, comienzan a adjuntar efectos: cambian la convolución foldl a foldM , proporcionan la totalidad a través de la mónada Either String , luego agregan registros, envuelven todo con el transformador WriterT , implementan el diccionario StateT para variables, y así sucesivamente. A veces, para demostrar la frescura de los cálculos monádicos, implementan una calculadora ambigua que devuelve todos los valores posibles de la expresión $$$(2 \ pm 3) * ((4 \ pm 8) \ pm 5)$ . Esta es una conversación larga, buena e interesante. Sin embargo, inmediatamente lideraremos nuestra historia de una manera diferente, aunque terminamos con el mismo resultado.

¿Por qué, en general, se trata de doblar? Porque la convolución (catamorfismo) es una abstracción del procesamiento secuencial de datos inductivos . La máquina de la pila se ejecuta linealmente a través del código, ejecuta una secuencia de instrucciones y genera un valor: el estado de la pila. Me gusta imaginar el trabajo de una máquina apiladora convolucional como traducción de ARN de matriz en una célula viva. El ribosoma atraviesa la cadena completa de ARN paso a paso, compara los tripletes de nucleótidos con aminoácidos y crea la estructura primaria de la proteína.

La máquina de convolución tiene una serie de limitaciones, lo principal es que el programa siempre se lee de principio a fin y una vez. Las llamadas de ramificación, bucles y subrutinas requieren un cambio conceptual en el intérprete. Nada complicado, por supuesto, pero esa máquina ya no puede describirse por una simple convolución.

Según la hipótesis de la relatividad lingüística, las propiedades del lenguaje que utilizamos afectan directamente las propiedades de nuestro pensamiento. Prestemos atención no a la máquina, sino a los lenguajes y programas que controla.

Todos los lenguajes orientados a la pila, tanto de nivel relativamente bajo (códigos de bytes de máquinas virtuales Java y Python o .NET) como los lenguajes de un nivel superior (PostScript, Forth o Joy), tienen una propiedad común fundamental: si escribe dos programas correctos en secuencia, entonces obtener el programa correcto Es cierto, correcto no significa "correcto", este programa puede bloquearse con un error en cualquier dato o fallar en ciclos interminables y no tiene ningún sentido, pero lo principal es que dicho programa puede ser ejecutado por la máquina. Al mismo tiempo, dividiendo el programa correcto en partes, podemos reutilizar fácilmente estas partes, precisamente por su corrección. Finalmente, en cualquier lenguaje de pila, puede seleccionar un subconjunto de comandos que operan solo en el estado interno de la máquina (pila o registros), sin usar ninguna memoria externa. Este subconjunto formará un lenguaje con la propiedad de concatenación . En dicho lenguaje, cualquier programa tiene el significado de un convertidor de estado de máquina, y la ejecución secuencial de programas es equivalente a su composición, lo que significa que también es un convertidor de estado.

Se observa el patrón general: la combinación (concatenación) de los programas correctos genera el programa correcto, la combinación de convertidores genera el convertidor. Resulta que los programas de lenguaje de pila están cerrados con respecto a la operación de concatenación o forman una estructura llamada un groupoid o magma . Esto significa que puede, al escribir el programa en cinta, cortarlo casi al azar y luego formar nuevos programas a partir de los segmentos resultantes. Además, puede cortar hasta segmentos con una sola instrucción.

Cuando se une, el orden es importante. Por ejemplo, estos dos programas son indudablemente diferentes:

¿Y qué nos da esto como programadores? La asociatividad le permite precompilar, optimizar e incluso paralelizar secciones de programa adecuadas arbitrarias para esto, y luego combinarlas en un programa equivalente. Podemos permitirnos realizar un análisis estático de cualquier parte del programa y usarlo en el análisis de todo el programa precisamente porque no nos importa dónde poner los corchetes. Estas son oportunidades muy importantes y serias para un lenguaje de bajo nivel o un idioma intermedio en el que no escribe una persona, sino un traductor. Y desde el punto de vista de un matemático y un trabajador funcional experimentado, esto hace que los programas de conversión de estado de máquina endomorfismos de pleno derecho. Los endomorfismos también forman un semigrupo con una operación de composición. En álgebra, tales endomorfismos se denominan semigrupos de transformación con respecto a algún conjunto. Por ejemplo, las máquinas de estados finitos forman un semigrupo de transformación de muchos estados.

"Semigroup" suena poco entusiasta, de alguna manera inferior. ¿Quizás los programas de pila forman un grupo ? Uh ... no, la mayoría de los programas son irreversibles, es decir, de acuerdo con el resultado de la ejecución, no será posible restaurar sin ambigüedad los datos originales. Pero tenemos un elemento neutral. En lenguajes ensambladores, se denota $$$\ texttt {nop}$ y no hace nada Si dicho operador no se define explícitamente en el idioma de la pila, se puede obtener fácilmente combinando algunos comandos, por ejemplo: $$$\ texttt {inc dic}$ , $$$\ texttt {dup pop}$ o $$$\ texttt {swap swap}$ . Dichos pares se pueden cortar de forma segura de los programas o, por el contrario, se pueden insertar en cualquier lugar de forma arbitraria. Como hay una unidad, nuestros programas forman un semigrupo con una unidad o monoide . Por lo tanto, puede implementarlos mediante programación en forma de monoides: endomorfismos sobre el estado de la máquina apilada. Esto le permitirá definir un pequeño conjunto de operaciones básicas para la máquina y luego crear programas utilizando su composición, obteniendo un lenguaje apilado en forma de un lenguaje específico de dominio incrustado (EDSL).

En Haskell, los semigrupos y monoides se describen utilizando las Monoid Semigroup y Semigroup . Sus definiciones son simples y reflejan solo la estructura básica, los requisitos de asociatividad y neutralidad deben ser verificados por el programador:

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

Construyendo un auto

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

Inmediatamente construiremos una máquina que tenga una pila, una memoria finita y pueda parar de emergencia de una manera buena y limpia. Todo esto se realiza sin el uso de mónadas, encapsulando los datos necesarios en un tipo que describe la máquina. Por lo tanto, todos los programas básicos, y por lo tanto todas sus combinaciones, serán convertidores puros de su estado.

Comencemos definiendo el tipo para la máquina virtual y las funciones de configuración trivial.

 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 

Se necesitan establecedores para hacer explícita la semántica del programa. Por procesador (tipo Processor ) nos referimos al convertidor VM -> VM .

Ahora definimos los tipos de envoltura para el monoide de transformación y para el 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) 

Los tipos de envoltura determinan el principio de combinar programas: estos son endomorfismos con el orden inverso de composición (de izquierda a derecha). El uso de contenedores permite al compilador determinar de forma independiente cómo el tipo de Program implementa los requisitos de las Monoid Semigroup y Semigroup .

El ejecutor del programa es trivial:

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

El mensaje de error será generado por la función err :

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

Usamos el tipo Maybe no como se usa habitualmente: un valor Nothing vacío en el estado significa que no está sucediendo nada peligroso, y los cálculos pueden continuar, a su vez, el valor de la cadena significa problemas. Para mayor comodidad, definimos dos constructores inteligentes: uno para los programas que funcionan solo con la pila y el otro para aquellos que necesitan memoria.

 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 

Ahora puede definir comandos de lenguaje básicos para trabajar con la pila y la memoria, la aritmética de enteros y también las relaciones de equivalencia y orden.

 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) 

Las ramificaciones y los bucles no son suficientes para un trabajo completo. En realidad, para el lenguaje incrustado, solo es suficiente la ramificación, los bucles se pueden organizar utilizando la recursión en el idioma del host (en Haskell), pero haremos que nuestro idioma sea autosuficiente. Además, aprovechamos el hecho de que los programas forman un semigrupo y determinamos el combinador de la repetición del programa el número especificado de veces. Tomará el número de repeticiones de la pila.

 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 

Los tipos de la branch y las funciones while indican que no se trata de programas independientes, sino de combinadores de programas: un enfoque típico al crear EDSL en Haskell. La función stimes define para todos los semigrupos; devuelve la composición del número especificado de elementos.

Finalmente, escribiremos algunos 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 

Resultó 120 líneas de código con comentarios y anotaciones de tipos que definen una máquina que opera con 18 comandos con tres combinadores. Así es como funciona nuestro automóvil.

 λ> 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 hecho, no hicimos nada nuevo: al combinar convertidores de endomorfismo, esencialmente volvimos a la convolución, pero se hizo implícita. Recuerde que la convolución proporciona una abstracción del procesamiento secuencial de datos inductivos. Los datos, en nuestro caso, se generan inductivamente cuando el operador pega los programas $$$\ diamante$ , y se "almacenan" en endomorfismo en forma de una cadena de composiciones de funciones de transformación de máquinas hasta que esta cadena se aplica al estado inicial. En el caso de los combinadores se branch y while cadena comienza a convertirse en un árbol o un bucle. En el caso general, obtenemos un gráfico que refleja el funcionamiento de un autómata con memoria de almacenamiento, es decir, una máquina apilada. Es esta estructura la que "colapsamos" durante la ejecución del programa.

¿Qué tan efectiva es esta implementación? La composición de funciones es lo mejor que puede hacer el compilador Haskell. ¡Él nació literalmente para esto! Cuando se trata de los beneficios de usar el conocimiento de los monoides, a menudo dan un ejemplo de listas de diferencias diffList , implementando una lista vinculada en forma de una composición de endomorfismos. Las listas de diferencias aceleran fundamentalmente la formación de listas a partir de muchas piezas debido a la asociatividad de la composición de funciones. Preocuparse por los tipos de envoltorios no conduce a un aumento de los gastos generales, se "disuelven" en la etapa de compilación. Del trabajo extra, solo queda una comprobación de estado en cada paso del programa.

Combinar monoides

Creo que en este momento los escépticos y los lectores casuales ya nos han dejado, puede permitirse relajarse y pasar al siguiente nivel de abstracción.

El concepto de semigrupos y monoides no sería tan útil y universal, si no fuera por una serie de propiedades inherentes a todos los semigrupos y monoides sin excepción, que nos permiten construir estructuras complejas a partir de estructuras simples de la misma manera que construimos programas complejos a partir de las simples. Estas propiedades ya no se aplican a los objetos, sino a los tipos, y es mejor escribirlos no en notación matemática, sino en forma de programas en Haskell, que, en virtud del isomorfismo de Curry-Howard, son sus pruebas.

1) Los monoides y semigrupos se pueden "multiplicar". Esto se refiere al producto de los tipos, cuya abstracción en Haskell es una tupla o un 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) Hay un solo monoide, está representado por un solo tipo () :

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

Con la operación de multiplicación, los propios semigrupos forman un semigrupo, y teniendo en cuenta el tipo de unidad, podemos decir que los monoides forman un monoide. La asociatividad y neutralidad de una unidad se cumple hasta el isomorfismo, pero esto no es importante.

3) Mapeos en una forma de semigrupo o monoide, respectivamente, un semigrupo o monoide. Y aquí, también es más fácil escribir esta declaración en Haskell:

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

Utilizaremos estos combinadores para expandir las capacidades del lenguaje de pila que hemos construido. Hagamos un cambio importante y hagamos que nuestros comandos básicos funcionen para devolver programas . Esto no los privará de sus propiedades monoidales, sino que permitirá ingresar información arbitraria desde el exterior al trabajo de todos los comandos de la máquina. Esto es lo que significa:

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

La información puede ser cualquier, por ejemplo, un diccionario externo con algunas definiciones, o una forma de mantener un registro de los cálculos necesarios durante la depuración. Esto es muy similar a la acción del Reader mónada, que, simplemente, es solo una función.

Introduciremos un registro en la estructura de la máquina, pero no lo vincularemos a ningún tipo en particular, sino que lo enviaremos al parámetro de tipo. Escribiremos en el diario utilizando la operación 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 

De ahora en adelante, nos permitimos no especificar anotaciones de tipo para todas las definiciones, dejando que el compilador las maneje de forma independiente, no son complicadas, aunque se vuelven engorrosas. Los equipos en sí no tendrán que cambiarse, gracias a los diseñadores inteligentes que se encargarán de todos los cambios. Bastante pequeño.

 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 

Queda por enseñar a ingresar información externa en el ejecutor del programa. Esto es muy fácil de hacer mediante la creación de diferentes artistas con diferentes estrategias de registro. El primer intérprete será el esfuerzo más simple, más silencioso y no desperdiciará en llevar un diario:

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

Aquí un solo monoide () fue útil: un elemento neutral en el álgebra monoide. Además, es posible definir una función para un ejecutor que esté listo para registrar esta o aquella información sobre el estado de la máquina en el diario.

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

La información puede ser, por ejemplo, como:

 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 

. , , . .

, — , . , . :

En la ejecución secuencial de los comandos de valencia se combinan de la siguiente manera no 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 

Y luego puedes construir un 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 , , — , , . , , . — ! , . , - . ( -) , . — ! "" , , , , . , , .

. - , . — , . .