lsystem (empty) → 1.2
raw patch · 12 files changed
+1222/−0 lines, 12 filesdep +basedep +haskell98dep +uu-parsinglibsetup-changed
Dependencies added: base, haskell98, uu-parsinglib, wx, wxcore
Files
- LICENSE +30/−0
- Makefile +7/−0
- README +31/−0
- Setup.hs +6/−0
- db/db.sl +144/−0
- lsystem.cabal +23/−0
- src/GenSequences.hs +12/−0
- src/Main.hs +114/−0
- src/ParserLS.hs +98/−0
- src/Process.hs +95/−0
- src/SistemaL.ag +144/−0
- src/SistemaL.hs +518/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Carlos Gomez++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Carlos Gomez nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Makefile view
@@ -0,0 +1,7 @@+SRC = ./src/++all: uuagc+ ghc -i$(SRC) --make -o lsystem $(SRC)Main.hs -outputdir out+ +uuagc:+ uuagc -P$(SRC) --data --module --semfuns --catas --signature $(SRC)SistemaL.ag
+ README view
@@ -0,0 +1,31 @@+Sistema-L / L-System+====================++Para compilar [basico]:++ runhaskell Setup.hs configure+ runhaskell Setup.hs build+ runhaskell Setup.hs install++o tambien: make++Para generar su documentacion y archivos fuente en la +documentacion (escribir anter de instalar y despues de construir el paquete):++ runhaskell Setup.hs hscolour+ runhaskell Setup.hs haddock --hyperlink-source++Tambien necesitaras copiar la carpeta 'db' al lugar donde se encuentra el ejecutable.++Para ejecutar:+ lsystem++Nota: Este programa ha sido reescrito para:+ San Simon Haskell Hackathone, Abril 2011+ Y vuelto a reescribir y mejorado para:+ Conferencias Ciencias de la Computación Bolivia++Autor:+ Carlos Gomez+ carliros.g@gmail.com+
+ Setup.hs view
@@ -0,0 +1,6 @@++import Distribution.Simple++main :: IO()+main = defaultMain+
+ db/db.sl view
@@ -0,0 +1,144 @@++Koch { alfabeto = [F, +, -]+ ; inicio = [F]+ ; producciones = [ F -> [F,+,F,-,F,-,F,+,F] ]+ }++Algae + { alfabeto = [Fa, Fb]+ ; inicio = [Fa]+ ; producciones = [ Fa -> [Fa, Fb]+ ; Fb -> [Fa]+ ]+ }++Fibonacci numbers + { alfabeto = [Fa,Fb]+ ; inicio = [Fa]+ ; producciones = [ Fa -> [Fb]+ ; Fb -> [Fa,Fb]+ ]+ }++Cantor 1 + { alfabeto = [Fa, Fb]+ ; inicio = [Fa]+ ; producciones = [ Fa -> [Fa,Fb,Fa]+ ; Fb -> [Fb,Fb,Fb]+ ]+ }++Cantor 2+ { alfabeto = [F,f,]+ ; inicio = [F]+ ; producciones = [ F -> [F,f,F]+ ; f -> [f,f,f]+ ]+ }++C Koch + { alfabeto = [F, +, -]+ ; inicio = [F,-,F,-,F,-,F]+ ; producciones = [ F -> [F,-,F,+,F,+,F,F,-,F,-,F,+,F] ]+ }++CKochis + { alfabeto = [F, +, -]+ ; inicio = [F,-,F,-,F,-,F]+ ; producciones = [ F -> [F,+,F,F,-,F,F,-,F,-,F,+,F,+,F,F,-,F,-,F,+,F,+,F,F,+,F,F,-,F] ]+ }++C Kochil + { alfabeto = [F, f,+, -]+ ; inicio = [F,+,F,+,F,+,F]+ ; producciones = [ F -> [F,+,f,-,F,F,+,F,+,F,F,+,F,f,+,F,F,-,f,+,F,F,-,F,-,F,F,-,F,f,-,F,F,F]+ ; f -> [f,f,f,f,f,f]]+ }++Koch A + { alfabeto = [F, +, -]+ ; inicio = [F,-,F,-,F,-,F]+ ; producciones = [ F -> [F,F,-,F,-,F,-,F,-,F,-,F,+,F] ]+ }++Koch B+ { alfabeto = [F, +, -]+ ; inicio = [F,-,F,-,F,-,F]+ ; producciones = [ F -> [F,F,-,F,-,F,-,F,-,F,F] ]+ }++Koch C+ { alfabeto = [F, +, -]+ ; inicio = [F,-,F,-,F,-,F]+ ; producciones = [ F -> [F,F,-,F,+,F,-,F,-,F,F] ]+ }++Koch D+ { alfabeto = [F, +, -]+ ; inicio = [F,-,F,-,F,-,F]+ ; producciones = [ F -> [F,F,-,F,-,-,F,-,F] ]+ }++Koch E + { alfabeto = [F, +, -]+ ; inicio = [F,-,F,-,F,-,F]+ ; producciones = [ F -> [F,-,F,F,-,-,F,-,F] ]+ }++Koch F+ { alfabeto = [F, +, -]+ ; inicio = [F,-,F,-,F,-,F]+ ; producciones = [ F -> [F,-,F,+,F,-,F,-,F] ]+ }++Dragon Curve+ { alfabeto = [Fl,Fr,+,-, red, blue]+ ; inicio = [Fl]+ ; producciones = [ Fl -> [red, Fl,+,Fr,+]+ ; Fr -> [blue,-,Fl,-,Fr]+ ]+ }++Sierpinski gasket+ { alfabeto = [Fl,Fr,+,-]+ ; inicio = [Fr]+ ; producciones = [ Fl -> [Fr,+,Fl,+,Fr]+ ; Fr -> [Fl,-,Fr,-,Fl]+ ]+ }++Hexagonal Gosper curve+ { alfabeto = [Fl,Fr,+,-]+ ; inicio = [Fl]+ ; producciones = [ Fl -> [Fl, +,Fr, +,+,Fr, -,Fl, -,-,Fl, Fl, -,Fr, +]+ ; Fr -> [-,Fl, +,Fr, Fr, +,+,Fr, +,Fl, -,-,Fl, -,Fr]+ ]+ }++Quadratic Gosper Curve+ { alfabeto = [Fr,Fl,+,-]+ ; inicio = [-,Fr]+ ; producciones = [ Fl -> [ Fl, Fl, -,Fr, -,Fr, +,Fl, +,Fl, -,Fr, -,Fr, Fl, +,Fr, +,Fl, Fl, Fr, -,Fl, +,Fr, +,Fl, Fl, +,Fr, -,Fl, Fr, -,Fr, -,Fl, +,Fl, +,Fr, Fr, -]+ ; Fr -> [+,Fl, Fl, -,Fr, -,Fr, +,Fl, +,Fl, Fr, +,Fl, -,Fr, Fr, -,Fl, -,Fr, +,Fl, Fr, Fr, -,Fl, -,Fr, Fl, +,Fl, +,Fr, -,Fr, -,Fl, +,Fl, +,Fr, Fr]+ ]+ }++3 x 3 Macrotile + { alfabeto = [L,R,F,+,-]+ ; inicio = [L]+ ; producciones = [ L -> [L,F,R,F,L,-,F,-,R,F,L,F,R,+,F,+,L,F,R,F,L]+ ; R -> [R,F,L,F,R,+,F,+,L,F,R,F,L,-,F,-,R,F,L,F,R]+ ]+ }++5 x 5 Macrotile+ { alfabeto = [L,R,F,+,-]+ ; inicio = [L]+ ; producciones = [ L -> [L,+,F,+,R,-,F,-,L,+,F,+,R,-,F,-,L,-,F,-,R,+,F,+,L,-,F,-,R,-,F,-,L,+,F,+,R,-,F,-,L,-,F,-,R,-,F,+ -,L,+,F,+,R,+,F,+,L,+,F,+,R,-,F,-,L,+,F,+,R,+,F,+,L,-,R,-,F,+,F,+,L,+,F,+,R,-,F,-,L,+,F,+,R,-,F,-,L]+ ; R -> [R,-,F,-,L,+,F,+,R,-,F,-,L,+,F,+,R,+,F,+,L,-,F,-,R,+,F,+,L,+,F,+,R,-,F,-,L,+,F,+,R,+,F,+,L,+,F,+,+ R,-,F,-,L,-,F,-,R,-,F,-,L,+,F,+,R,-,F,-,L,-,F,-,R,+,F,+,L,-,F,-,R,-,F,-,L,+,F,+,R,-,F,-,L,+,F,+,R]+ ]++ }+
+ lsystem.cabal view
@@ -0,0 +1,23 @@+Name: lsystem+Version: 1.2+Category: Application+Synopsis: Paint an L-System Grammar+Description: Paint an L-System Grammar+License: BSD3+license-file: LICENSE+Author: Carlos Gomez+Maintainer: carliros.g@gmail.com+Build-Type: Simple+Cabal-Version: >=1.2+Extra-source-files: LICENSE, README, Makefile, + src/GenSequences.hs, src/Main.hs, src/ParserLS.hs, src/Process.hs, src/SistemaL.ag, src/SistemaL.hs,+ db/db.sl++Executable lsystem+ Hs-source-dirs: src+ Main-is: Main.hs+ Build-Depends: base >= 4.2 && < 5,+ haskell98,+ wxcore,+ wx,+ uu-parsinglib
+ src/GenSequences.hs view
@@ -0,0 +1,12 @@+-- | Describes how to generate the sequences of an L-System grammar+module GenSequences where++import SistemaL++generate :: SistemaL -> Int -> [Simbolo]+generate (SistemaL _ _ init prods) n = generate' init prods n+ where generate' seq prods 0 = seq+ generate' seq prods n = let seq' = concat [lst | s1 <- seq, (s2,lst) <- prods, s1 == s2]+ in generate' seq' prods (n-1)++
+ src/Main.hs view
@@ -0,0 +1,114 @@+{-|+User Interface and Compilation process for L-System and Turtle movement++student: Carlos Gomez+date: Sat May 15 22:51:57 BOT 2010+-}+module Main where++import Graphics.UI.WXCore+import Graphics.UI.WX+import GenSequences+import Process+import ParserLS+import SistemaL++main :: IO()+main = start gui++-- | GUI for L-system+gui :: IO()+gui = do -- read the data base file of l-system+ db <- readDataBase+ -- variables+ dbls <- variable [value := db] -- lista of l-systems+ points <- variable [value := []] -- list of point draw lines+ lsystem <- variable [value := head db] -- actual l-system to use++ f <- frame [text := "L-System And Turtle Movement"]+ screen <- panel f [on paint := onScreenPaint points] -- screen is the place where to draw the lines++ -- state turtle+ spanel <- panel f []+ xs <- entry spanel [text := "200"]+ ys <- entry spanel [text := "200"]+ as <- entry spanel [text := "0"]+ ds <- entry spanel [text := "10"]+ bs <- entry spanel [text := "90"]+ nl <- entry spanel [text := "1"]+ brender <- button f [text := "Render", on command := render lsystem points xs ys as ds bs nl screen]+ bclear <- button f [text := "Clear" , on command := set points [value := []] >> repaint screen]+ let opts = map getNombre db+ lstB <- choice spanel [items := opts, selection := 0]+ set lstB [on select := chgSystem lsystem lstB dbls]+ updateDB <- button spanel [text := "Update DB", on command := updateDataBase lstB dbls lsystem]+ set spanel [layout := row 5 $+ [ boxed "state turtle" (column 5 [ row 5 [label "x:", widget xs, label "y:", widget ys, label "angle a:", widget as]+ , row 5 [label "distance:", widget ds, label "angle b:", widget bs]])+ , hfill $ boxed "L-System" (row 5 [label "L-System", widget lstB, label "Nro-Iterations", widget nl, widget updateDB])+ ]]+ set f [layout := column 5 [ hfill $ widget spanel+ , fill $ widget screen+ , row 5 [hfill $ widget brender, hfill $ widget bclear]]]+ return ()++updateDataBase lstB dbls lsystem+ = do db <- readDataBase+ set dbls [value := db]+ let opts = map getNombre db+ set lstB [items := opts]+ set lsystem [value := head db]+ return ()++readDataBase + = do lss <- catch (parseFileSistemasL "./db/db.sl") (\err -> putStrLn (show err) >> return [])+ let defaultLS = SistemaL "Single Line" [Simbolo "F"] [Simbolo "F"] [(Simbolo "F",[Simbolo "F"])]+ return $ defaultLS : lss++-- | change the actual L-System to another+chgSystem lsystem chc dbls+ = do n <- get chc selection+ db <- get dbls value+ let ls = db !! n+ set lsystem [value := ls]++-- | generate a sequence and then render the sequence on screen+render lsystem points xs ys an ds bn nl screen + = do x <- get xs text+ y <- get ys text+ a <- get an text+ d <- get ds text+ b <- get bn text+ ns <- get nl text+ ls <- get lsystem value+ let c = black -- default init color+ -- we generate the sequense+ let sequence = generate ls (toInt ns)+ let tortuga = ((toDouble x, toDouble y, toRad (toDouble a)), toDouble d, toRad (toDouble b), c)+ listPoints <- get points value+ let newPoints = processSequence sequence tortuga listPoints+ set points [value := newPoints]+ repaint screen++-- | draw lines on screen according to the list of points+onScreenPaint points dc (Rect rx ry dx dy) + = do lst <- get points value+ mapM_ drawP lst+ where drawP ((x,y), (x',y'), c) = line dc (pt x (dy-y)) (pt x' (dy-y')) [color := c]++-- | Converts to Radians+toRad :: Double -> Double+toRad n = n / 360 * 2 * pi++-- | Converts to Int+toInt :: String -> Int+toInt = read++-- | Converts to Double+toDouble :: String -> Double+toDouble = read . fix+ where fix xss@(x:xs) = if x == '.' then '0':xss+ else let (tr, sr) = splitAt 2 xss+ in if tr == "-." then "-0."++sr+ else xss+
+ src/ParserLS.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-}+module ParserLS where++import Text.ParserCombinators.UU+import Text.ParserCombinators.UU.BasicInstances+import Text.ParserCombinators.UU.Utils+import SistemaL+import Data.Char+import Data.Maybe+import Data.List+import Text.Printf++-- %% Parser Interface %%+--execParser' :: Parser a -> String -> (a, [Error LineColPos])+--execParser' p = parse ((,) <$> p <*> pEnd) . createStr (LineColPos 0 0 0)++runParser' :: String -> Parser a -> String -> IO a+runParser' inputName p s+ = do let (a,b) = execParser p s + if null b+ then return a+ else printf "Failed parsing '%s' :\n%s" inputName (showErrors s b) >> return a+ where showErrors :: String -> [Error LineColPos] -> String+ showErrors s errs = foldr (\e r -> "-> " ++ (pruneError s e) ++ r) "\n" errs+ pruneError :: String -> Error LineColPos -> String+ pruneError _ (DeletedAtEnd x ) = printf "\nUnexpected '%s' at end." x+ pruneError s (Inserted x pos exp) = prettyError s exp pos ++ printf "\n\t Corrected with inserting: '%s'" x+ pruneError s (Deleted x pos exp) = prettyError s exp pos ++ printf "\n\t Corrected with deleting: %s" x++ prettyError :: String -> [String] -> LineColPos -> String+ prettyError s exp p@(LineColPos line c abs) = printf "\nExpected %s at %s :\n%s\n%s\n%s\n"+ (show_expecting p exp)+ (show p)+ aboveString+ inputFrag+ belowString+ where+ s' = map (\c -> if c=='\n' || c=='\r' || c=='\t' then ' ' else c) s+ aboveString = replicate 30 ' ' ++ "v"+ belowString = replicate 30 ' ' ++ "^"+ inputFrag = replicate (30 - c) ' ' ++ (take 71 $ drop (c - 30) s')+++parseFileSistemasL :: FilePath -> IO [SistemaL]+parseFileSistemasL file + = do input <- readFile file+ res <- runParser' file pSistemasL input+ mbres <- mapM verificar res+ return $ catMaybes mbres+ where verificar sl = case (testSistemaL sl) of+ Left errs -> do mapM_ putStrLn errs+ return Nothing+ Right sl -> return $ Just sl++pSistemasL :: Parser [SistemaL]+pSistemasL = pSpaces *> pList pSistemaL <* pSpaces++pSistemaL :: Parser SistemaL+pSistemaL = SistemaL <$> pNombre <* pSymbol "{" <*> pAlfabeto+ <* pSymbol ";" <*> pInicio+ <* pSymbol ";" <*> pProducciones+ <* pSymbol "}"++pAlfabeto :: Parser Alfabeto+pAlfabeto = pKeyword "alfabeto" *> pSymbol "=" *> pListaS1 (pSymbol ",") pSLSimbolo++pInicio :: Parser Inicio+pInicio = pKeyword "inicio" *> pSymbol "=" *> pListaS1 (pSymbol ",") pSLSimbolo++pProducciones :: Parser Producciones+pProducciones = pKeyword "producciones" *> pSymbol "=" *> pListaS1 (pSymbol ";") pProduccion++pProduccion :: Parser Produccion+pProduccion = (,) <$> pSLSimbolo <* pSymbol "->" <*> pListaS1 (pSymbol ",") pSLSimbolo++pListaS1 :: Parser String -> Parser a -> Parser [a]+pListaS1 sep simb = pSymbol "[" + *> pList1Sep sep simb <*+ pSymbol "]" ++pListaS :: Parser String -> Parser a -> Parser [a]+pListaS sep simb = pSymbol "[" + *> pListSep sep simb <*+ pSymbol "]" ++pNombre :: Parser String+pNombre = lexeme $ unwords <$> pList1Sep_ng pSpaces pSimpleWord++pSLSimbolo :: Parser Simbolo+pSLSimbolo = lexeme $ Simbolo <$> pMunch funchar+ where funchar c = not $ elem c "[]{},; \n\r\t"++-- auxiliar parsers+pSimpleWord :: Parser String+pSimpleWord = pList1 (pLetter <|> pDigit) <?> "Simple Word"++pKeyword :: String -> Parser String+pKeyword = lexeme . pToken
+ src/Process.hs view
@@ -0,0 +1,95 @@+-- | Este modulo abstrae el movimiento Tortuga, su estado y la forma en que lo procesa+module Process (+-- * Estado Tortuga+ Tortuga+, Estado+, Distancia+, Angulo+, PosX+, PosY+, Points+-- * Procesar Secuancia+, processSequence+) where++import SistemaL+import Graphics.UI.WX.Types++-- | Representa el estado de una tortuga+type Tortuga = ( Estado -- estado actual de la tortuga+ , Distancia -- distancia que que avanza la tortuga+ , Angulo -- angulo con que gira+ , Color -- color con el que dibuja+ )++type Distancia = Double+type Angulo = Double+type PosX = Double+type PosY = Double++-- | Representa el estado actual de una tortuga+type Estado = ( PosX -- su posicion x+ , PosY -- su posicion y+ , Angulo -- su angulo+ )++type Points = [((Int,Int),(Int,Int), Color)]++-- | procesa una lista de secuencias+processSequence :: [Simbolo] -> Tortuga -> Points -> Points+processSequence seq state points + = let (newPoints,newState) = foldl funMix (points,state) seq+ in newPoints+ where funMix (points, state) cmd = doCommand cmd state points++-- | procesar un comando especifico+doCommand :: Simbolo -> Tortuga -> Points -> (Points,Tortuga)+doCommand simb state@((x,y,an),d,bn,c) points+ = let getCmd (Simbolo str) = head str+ getCmdName (Simbolo str) = str+ in case getCmd simb of+ 'F' -> let (x', y') = (x + d * cos an, y + d * sin an)+ ptline = ((round x, round y),(round x',round y'), c)+ newPoints = ptline : points+ newState = ((x', y', an), d, bn, c)+ in (newPoints, newState) ++ 'f' -> let (x', y') = (x + d * cos an, y + d * sin an)+ newState = ((x', y', an), d, bn, c)+ in (points, newState)++ '+' -> let newState = ((x, y, an + bn), d, bn, c)+ in (points, newState) + + '-' -> let newState = ((x, y, an - bn), d, bn, c)+ in (points, newState) ++ _ -> case getCmdName simb of+ "black" -> let newState = ((x, y, an), d, bn, black)+ in (points, newState)+ "darkgrey" -> let newState = ((x, y, an), d, bn, darkgrey)+ in (points, newState)+ "dimgrey" -> let newState = ((x, y, an), d, bn, dimgrey)+ in (points, newState)+ "mediumgrey" -> let newState = ((x, y, an), d, bn, mediumgrey)+ in (points, newState)+ "grey" -> let newState = ((x, y, an), d, bn, grey)+ in (points, newState)+ "lightgrey" -> let newState = ((x, y, an), d, bn, lightgrey)+ in (points, newState)+ "white" -> let newState = ((x, y, an), d, bn, white)+ in (points, newState)+ "red" -> let newState = ((x, y, an), d, bn, red)+ in (points, newState)+ "green" -> let newState = ((x, y, an), d, bn, green)+ in (points, newState)+ "blue" -> let newState = ((x, y, an), d, bn, blue)+ in (points, newState)+ "cyan" -> let newState = ((x, y, an), d, bn, cyan)+ in (points, newState)+ "magenta" -> let newState = ((x, y, an), d, bn, magenta)+ in (points, newState)+ "yellow" -> let newState = ((x, y, an), d, bn, yellow)+ in (points, newState)+ _ -> (points,state) -- error "[Process] Unknow Command."+
+ src/SistemaL.ag view
@@ -0,0 +1,144 @@+PRAGMA genlinepragmas++imports{+import Data.List+}++DATA SistemaL + | SistemaL nombre : String+ alfabeto : Alfabeto+ inicio : Inicio+ producciones : Producciones++DATA Simbolo+ | Simbolo String++TYPE Alfabeto = [Simbolo]+TYPE Inicio = [Simbolo]+TYPE Producciones = [Produccion]+TYPE Produccion = (Simbolo, Succesor)+TYPE Succesor = [Simbolo]++DERIVING *: Show+DERIVING Simbolo: Eq++-- construimos el alfabeto de un sistema l+ATTR Alfabeto [|alf: {[String]}|]+SEM SistemaL+ | SistemaL alfabeto.alf = []++SEM Alfabeto+ | Cons loc.verificar = elem @hd.simb @lhs.alf+ tl.alf = if @loc.verificar+ then @lhs.alf+ else @hd.simb : @lhs.alf+ lhs.alf = @tl.alf+ | Nil lhs.alf = @lhs.alf++-- compartimos el alfabeto a la estructura+ATTR Inicio Producciones Produccion Succesor [alfabeto: {[String]} ||]+SEM SistemaL+ | SistemaL inicio.alfabeto = @alfabeto.alf+ producciones.alfabeto = @alfabeto.alf++-- subimos el simbolo+ATTR Produccion Simbolo [|| simb: String ]+SEM Simbolo+ | Simbolo lhs.simb = @string++-- construyendo el resultado+ATTR SistemaL [|| resultado: {Either [String] SistemaL}]+SEM SistemaL+ | SistemaL lhs.resultado = if null @loc.errores+ then let producciones = addIdentProds @producciones.prods @alfabeto.alf+ in Right (SistemaL @nombre @alfabeto.self @inicio.self producciones)+ else Left @loc.errores++ATTR Alfabeto Inicio Produccion Succesor Simbolo [|| self: SELF]+ATTR Producciones [|prods: {Producciones}|]+SEM Producciones+ | Cons loc.verificar = myElem @hd.simb @lhs.prods+ tl.prods = if @loc.verificar+ then @lhs.prods+ else @hd.self : @lhs.prods+ lhs.prods = @tl.prods++SEM SistemaL+ | SistemaL producciones.prods = []++{+addIdentProds prods alfa + = let prods' = map (\(Simbolo e,_) -> e) prods+ resto = alfa \\ prods'+ iprods = map (\e -> (Simbolo e, [Simbolo e])) resto+ in prods ++ iprods++myElem _ [] = False+myElem e1 ((Simbolo e2,_):xs) = if e1 == e2+ then True+ else myElem e1 xs+}++-- Errores+ATTR Alfabeto Inicio Producciones Produccion Succesor [|| errores: {[String]}]+SEM SistemaL+ | SistemaL loc.errores+ = let inicioErr = if null @inicio.self+ then "La lista de simbolos de inicio no puede ser vacia" : @inicio.errores+ else @inicio.errores+ errores = map (\err -> @nombre ++ ": " ++ err) (@alfabeto.errores ++ inicioErr ++ @producciones.errores)+ in errores++SEM Alfabeto+ | Cons lhs.errores = if @loc.verificar+ then ("El simbolo: '" ++ @hd.simb ++ "' esta repetido mas de una ves en el alfabeto.") : @tl.errores+ else @tl.errores+ | Nil lhs.errores = []++SEM Inicio+ | Cons lhs.errores = if elem @hd.simb @lhs.alfabeto+ then @tl.errores+ else ("El simbolo de inicio: '" ++ @hd.simb ++ "' no se encuentra en el alfabeto.") : @tl.errores+ | Nil lhs.errores = []++SEM Producciones+ | Cons lhs.errores = if @loc.verificar+ then let error = "La produccion con el simb. izq.:'" + ++ @hd.simb + ++ "' esta repetida mas de una ves en la lista de producciones."+ in (error : @hd.errores) ++ @tl.errores+ else @hd.errores ++ @tl.errores+ | Nil lhs.errores = []++SEM Produccion+ | Tuple lhs.errores = if elem @x1.simb @lhs.alfabeto+ then @x2.errores+ else ("El simbolo de la produccion (izq): '" ++ @x1.simb ++ "' no se encuentra en el alfabeto.") : @x2.errores++SEM Succesor+ | Cons lhs.errores = if elem @hd.simb @lhs.alfabeto+ then @tl.errores+ else ("El simbolo de la produccion (der): '" ++ @hd.simb ++ "' no se encuentra en el alfabeto.") : @tl.errores+ | Nil lhs.errores = []+++{+ejemplo1 = SistemaL "Koch" alfaK initK prodK+alfaK = [Simbolo "F", Simbolo "f", Simbolo "+", Simbolo "-"]+initK = [Simbolo "F", Simbolo "a"]+prodK = [ (Simbolo "F", [Simbolo "F", Simbolo "g"])+ , (Simbolo "F", [])+ ]++ejemplo2 = SistemaL "Koch" alfaK2 initK2 prodK2+alfaK2 = [Simbolo "F", Simbolo "f", Simbolo "+", Simbolo "-"]+initK2 = [Simbolo "F", Simbolo "f"]+prodK2 = [ (Simbolo "F", [Simbolo "F", Simbolo "+"])+ , (Simbolo "f", [])+ ]++getNombre (SistemaL nm _ _ _) = nm++testSistemaL :: SistemaL -> Either [String] SistemaL+testSistemaL = sem_SistemaL+}
+ src/SistemaL.hs view
@@ -0,0 +1,518 @@+++-- UUAGC 0.9.38.6 (./src/SistemaL.ag)+module SistemaL where+{-# LINE 3 "./src/SistemaL.ag" #-}++import Data.List+{-# LINE 9 "./src/SistemaL.hs" #-}++{-# LINE 69 "./src/SistemaL.ag" #-}++addIdentProds prods alfa + = let prods' = map (\(Simbolo e,_) -> e) prods+ resto = alfa \\ prods'+ iprods = map (\e -> (Simbolo e, [Simbolo e])) resto+ in prods ++ iprods++myElem _ [] = False+myElem e1 ((Simbolo e2,_):xs) = if e1 == e2+ then True+ else myElem e1 xs+{-# LINE 23 "./src/SistemaL.hs" #-}++{-# LINE 125 "./src/SistemaL.ag" #-}++ejemplo1 = SistemaL "Koch" alfaK initK prodK+alfaK = [Simbolo "F", Simbolo "f", Simbolo "+", Simbolo "-"]+initK = [Simbolo "F", Simbolo "a"]+prodK = [ (Simbolo "F", [Simbolo "F", Simbolo "g"])+ , (Simbolo "F", [])+ ]++ejemplo2 = SistemaL "Koch" alfaK2 initK2 prodK2+alfaK2 = [Simbolo "F", Simbolo "f", Simbolo "+", Simbolo "-"]+initK2 = [Simbolo "F", Simbolo "f"]+prodK2 = [ (Simbolo "F", [Simbolo "F", Simbolo "+"])+ , (Simbolo "f", [])+ ]++getNombre (SistemaL nm _ _ _) = nm++testSistemaL :: SistemaL -> Either [String] SistemaL+testSistemaL = sem_SistemaL+{-# LINE 45 "./src/SistemaL.hs" #-}+-- Alfabeto ----------------------------------------------------+type Alfabeto = [Simbolo ]+-- cata+sem_Alfabeto :: Alfabeto ->+ T_Alfabeto +sem_Alfabeto list =+ (Prelude.foldr sem_Alfabeto_Cons sem_Alfabeto_Nil (Prelude.map sem_Simbolo list) )+-- semantic domain+type T_Alfabeto = ([String]) ->+ ( ([String]),([String]),Alfabeto )+sem_Alfabeto_Cons :: T_Simbolo ->+ T_Alfabeto ->+ T_Alfabeto +sem_Alfabeto_Cons hd_ tl_ =+ (\ _lhsIalf ->+ (let _tlOalf :: ([String])+ _lhsOalf :: ([String])+ _lhsOerrores :: ([String])+ _lhsOself :: Alfabeto + _hdIself :: Simbolo + _hdIsimb :: String+ _tlIalf :: ([String])+ _tlIerrores :: ([String])+ _tlIself :: Alfabeto + _verificar =+ ({-# LINE 31 "./src/SistemaL.ag" #-}+ elem _hdIsimb _lhsIalf+ {-# LINE 73 "./src/SistemaL.hs" #-}+ )+ _tlOalf =+ ({-# LINE 32 "./src/SistemaL.ag" #-}+ if _verificar+ then _lhsIalf+ else _hdIsimb : _lhsIalf+ {-# LINE 80 "./src/SistemaL.hs" #-}+ )+ _lhsOalf =+ ({-# LINE 35 "./src/SistemaL.ag" #-}+ _tlIalf+ {-# LINE 85 "./src/SistemaL.hs" #-}+ )+ _lhsOerrores =+ ({-# LINE 93 "./src/SistemaL.ag" #-}+ if _verificar+ then ("El simbolo: '" ++ _hdIsimb ++ "' esta repetido mas de una ves en el alfabeto.") : _tlIerrores+ else _tlIerrores+ {-# LINE 92 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ (:) _hdIself _tlIself+ {-# LINE 97 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 102 "./src/SistemaL.hs" #-}+ )+ ( _hdIself,_hdIsimb) =+ hd_ + ( _tlIalf,_tlIerrores,_tlIself) =+ tl_ _tlOalf + in ( _lhsOalf,_lhsOerrores,_lhsOself)))+sem_Alfabeto_Nil :: T_Alfabeto +sem_Alfabeto_Nil =+ (\ _lhsIalf ->+ (let _lhsOalf :: ([String])+ _lhsOerrores :: ([String])+ _lhsOself :: Alfabeto + _lhsOalf =+ ({-# LINE 36 "./src/SistemaL.ag" #-}+ _lhsIalf+ {-# LINE 118 "./src/SistemaL.hs" #-}+ )+ _lhsOerrores =+ ({-# LINE 96 "./src/SistemaL.ag" #-}+ []+ {-# LINE 123 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ []+ {-# LINE 128 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 133 "./src/SistemaL.hs" #-}+ )+ in ( _lhsOalf,_lhsOerrores,_lhsOself)))+-- Inicio ------------------------------------------------------+type Inicio = [Simbolo ]+-- cata+sem_Inicio :: Inicio ->+ T_Inicio +sem_Inicio list =+ (Prelude.foldr sem_Inicio_Cons sem_Inicio_Nil (Prelude.map sem_Simbolo list) )+-- semantic domain+type T_Inicio = ([String]) ->+ ( ([String]),Inicio )+sem_Inicio_Cons :: T_Simbolo ->+ T_Inicio ->+ T_Inicio +sem_Inicio_Cons hd_ tl_ =+ (\ _lhsIalfabeto ->+ (let _lhsOerrores :: ([String])+ _lhsOself :: Inicio + _tlOalfabeto :: ([String])+ _hdIself :: Simbolo + _hdIsimb :: String+ _tlIerrores :: ([String])+ _tlIself :: Inicio + _lhsOerrores =+ ({-# LINE 99 "./src/SistemaL.ag" #-}+ if elem _hdIsimb _lhsIalfabeto+ then _tlIerrores+ else ("El simbolo de inicio: '" ++ _hdIsimb ++ "' no se encuentra en el alfabeto.") : _tlIerrores+ {-# LINE 163 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ (:) _hdIself _tlIself+ {-# LINE 168 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 173 "./src/SistemaL.hs" #-}+ )+ _tlOalfabeto =+ ({-# LINE 39 "./src/SistemaL.ag" #-}+ _lhsIalfabeto+ {-# LINE 178 "./src/SistemaL.hs" #-}+ )+ ( _hdIself,_hdIsimb) =+ hd_ + ( _tlIerrores,_tlIself) =+ tl_ _tlOalfabeto + in ( _lhsOerrores,_lhsOself)))+sem_Inicio_Nil :: T_Inicio +sem_Inicio_Nil =+ (\ _lhsIalfabeto ->+ (let _lhsOerrores :: ([String])+ _lhsOself :: Inicio + _lhsOerrores =+ ({-# LINE 102 "./src/SistemaL.ag" #-}+ []+ {-# LINE 193 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ []+ {-# LINE 198 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 203 "./src/SistemaL.hs" #-}+ )+ in ( _lhsOerrores,_lhsOself)))+-- Produccion --------------------------------------------------+type Produccion = ( Simbolo ,Succesor )+-- cata+sem_Produccion :: Produccion ->+ T_Produccion +sem_Produccion ( x1,x2) =+ (sem_Produccion_Tuple (sem_Simbolo x1 ) (sem_Succesor x2 ) )+-- semantic domain+type T_Produccion = ([String]) ->+ ( ([String]),Produccion ,String)+sem_Produccion_Tuple :: T_Simbolo ->+ T_Succesor ->+ T_Produccion +sem_Produccion_Tuple x1_ x2_ =+ (\ _lhsIalfabeto ->+ (let _lhsOerrores :: ([String])+ _lhsOself :: Produccion + _lhsOsimb :: String+ _x2Oalfabeto :: ([String])+ _x1Iself :: Simbolo + _x1Isimb :: String+ _x2Ierrores :: ([String])+ _x2Iself :: Succesor + _lhsOerrores =+ ({-# LINE 114 "./src/SistemaL.ag" #-}+ if elem _x1Isimb _lhsIalfabeto+ then _x2Ierrores+ else ("El simbolo de la produccion (izq): '" ++ _x1Isimb ++ "' no se encuentra en el alfabeto.") : _x2Ierrores+ {-# LINE 234 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ (_x1Iself,_x2Iself)+ {-# LINE 239 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 244 "./src/SistemaL.hs" #-}+ )+ _lhsOsimb =+ ({-# LINE 45 "./src/SistemaL.ag" #-}+ _x1Isimb+ {-# LINE 249 "./src/SistemaL.hs" #-}+ )+ _x2Oalfabeto =+ ({-# LINE 39 "./src/SistemaL.ag" #-}+ _lhsIalfabeto+ {-# LINE 254 "./src/SistemaL.hs" #-}+ )+ ( _x1Iself,_x1Isimb) =+ x1_ + ( _x2Ierrores,_x2Iself) =+ x2_ _x2Oalfabeto + in ( _lhsOerrores,_lhsOself,_lhsOsimb)))+-- Producciones ------------------------------------------------+type Producciones = [Produccion ]+-- cata+sem_Producciones :: Producciones ->+ T_Producciones +sem_Producciones list =+ (Prelude.foldr sem_Producciones_Cons sem_Producciones_Nil (Prelude.map sem_Produccion list) )+-- semantic domain+type T_Producciones = ([String]) ->+ Producciones ->+ ( ([String]),Producciones)+sem_Producciones_Cons :: T_Produccion ->+ T_Producciones ->+ T_Producciones +sem_Producciones_Cons hd_ tl_ =+ (\ _lhsIalfabeto+ _lhsIprods ->+ (let _tlOprods :: Producciones+ _lhsOprods :: Producciones+ _lhsOerrores :: ([String])+ _hdOalfabeto :: ([String])+ _tlOalfabeto :: ([String])+ _hdIerrores :: ([String])+ _hdIself :: Produccion + _hdIsimb :: String+ _tlIerrores :: ([String])+ _tlIprods :: Producciones+ _verificar =+ ({-# LINE 60 "./src/SistemaL.ag" #-}+ myElem _hdIsimb _lhsIprods+ {-# LINE 291 "./src/SistemaL.hs" #-}+ )+ _tlOprods =+ ({-# LINE 61 "./src/SistemaL.ag" #-}+ if _verificar+ then _lhsIprods+ else _hdIself : _lhsIprods+ {-# LINE 298 "./src/SistemaL.hs" #-}+ )+ _lhsOprods =+ ({-# LINE 64 "./src/SistemaL.ag" #-}+ _tlIprods+ {-# LINE 303 "./src/SistemaL.hs" #-}+ )+ _lhsOerrores =+ ({-# LINE 105 "./src/SistemaL.ag" #-}+ if _verificar+ then let error = "La produccion con el simb. izq.:'"+ ++ _hdIsimb+ ++ "' esta repetida mas de una ves en la lista de producciones."+ in (error : _hdIerrores) ++ _tlIerrores+ else _hdIerrores ++ _tlIerrores+ {-# LINE 313 "./src/SistemaL.hs" #-}+ )+ _hdOalfabeto =+ ({-# LINE 39 "./src/SistemaL.ag" #-}+ _lhsIalfabeto+ {-# LINE 318 "./src/SistemaL.hs" #-}+ )+ _tlOalfabeto =+ ({-# LINE 39 "./src/SistemaL.ag" #-}+ _lhsIalfabeto+ {-# LINE 323 "./src/SistemaL.hs" #-}+ )+ ( _hdIerrores,_hdIself,_hdIsimb) =+ hd_ _hdOalfabeto + ( _tlIerrores,_tlIprods) =+ tl_ _tlOalfabeto _tlOprods + in ( _lhsOerrores,_lhsOprods)))+sem_Producciones_Nil :: T_Producciones +sem_Producciones_Nil =+ (\ _lhsIalfabeto+ _lhsIprods ->+ (let _lhsOerrores :: ([String])+ _lhsOprods :: Producciones+ _lhsOerrores =+ ({-# LINE 111 "./src/SistemaL.ag" #-}+ []+ {-# LINE 339 "./src/SistemaL.hs" #-}+ )+ _lhsOprods =+ ({-# LINE 58 "./src/SistemaL.ag" #-}+ _lhsIprods+ {-# LINE 344 "./src/SistemaL.hs" #-}+ )+ in ( _lhsOerrores,_lhsOprods)))+-- Simbolo -----------------------------------------------------+data Simbolo = Simbolo (String) + deriving ( Eq,Show)+-- cata+sem_Simbolo :: Simbolo ->+ T_Simbolo +sem_Simbolo (Simbolo _string ) =+ (sem_Simbolo_Simbolo _string )+-- semantic domain+type T_Simbolo = ( Simbolo ,String)+sem_Simbolo_Simbolo :: String ->+ T_Simbolo +sem_Simbolo_Simbolo string_ =+ (let _lhsOsimb :: String+ _lhsOself :: Simbolo + _lhsOsimb =+ ({-# LINE 47 "./src/SistemaL.ag" #-}+ string_+ {-# LINE 365 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ Simbolo string_+ {-# LINE 370 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 375 "./src/SistemaL.hs" #-}+ )+ in ( _lhsOself,_lhsOsimb))+-- SistemaL ----------------------------------------------------+data SistemaL = SistemaL (String) (Alfabeto ) (Inicio ) (Producciones ) + deriving ( Show)+-- cata+sem_SistemaL :: SistemaL ->+ T_SistemaL +sem_SistemaL (SistemaL _nombre _alfabeto _inicio _producciones ) =+ (sem_SistemaL_SistemaL _nombre (sem_Alfabeto _alfabeto ) (sem_Inicio _inicio ) (sem_Producciones _producciones ) )+-- semantic domain+type T_SistemaL = ( (Either [String] SistemaL))+sem_SistemaL_SistemaL :: String ->+ T_Alfabeto ->+ T_Inicio ->+ T_Producciones ->+ T_SistemaL +sem_SistemaL_SistemaL nombre_ alfabeto_ inicio_ producciones_ =+ (let _alfabetoOalf :: ([String])+ _inicioOalfabeto :: ([String])+ _produccionesOalfabeto :: ([String])+ _lhsOresultado :: (Either [String] SistemaL)+ _produccionesOprods :: Producciones+ _alfabetoIalf :: ([String])+ _alfabetoIerrores :: ([String])+ _alfabetoIself :: Alfabeto + _inicioIerrores :: ([String])+ _inicioIself :: Inicio + _produccionesIerrores :: ([String])+ _produccionesIprods :: Producciones+ _alfabetoOalf =+ ({-# LINE 28 "./src/SistemaL.ag" #-}+ []+ {-# LINE 409 "./src/SistemaL.hs" #-}+ )+ _inicioOalfabeto =+ ({-# LINE 41 "./src/SistemaL.ag" #-}+ _alfabetoIalf+ {-# LINE 414 "./src/SistemaL.hs" #-}+ )+ _produccionesOalfabeto =+ ({-# LINE 42 "./src/SistemaL.ag" #-}+ _alfabetoIalf+ {-# LINE 419 "./src/SistemaL.hs" #-}+ )+ _lhsOresultado =+ ({-# LINE 52 "./src/SistemaL.ag" #-}+ if null _errores+ then let producciones = addIdentProds _produccionesIprods _alfabetoIalf+ in Right (SistemaL nombre_ _alfabetoIself _inicioIself producciones)+ else Left _errores+ {-# LINE 427 "./src/SistemaL.hs" #-}+ )+ _produccionesOprods =+ ({-# LINE 67 "./src/SistemaL.ag" #-}+ []+ {-# LINE 432 "./src/SistemaL.hs" #-}+ )+ _errores =+ ({-# LINE 85 "./src/SistemaL.ag" #-}+ let inicioErr = if null _inicioIself+ then "La lista de simbolos de inicio no puede ser vacia" : _inicioIerrores+ else _inicioIerrores+ errores = map (\err -> nombre_ ++ ": " ++ err) (_alfabetoIerrores ++ inicioErr ++ _produccionesIerrores)+ in errores+ {-# LINE 441 "./src/SistemaL.hs" #-}+ )+ ( _alfabetoIalf,_alfabetoIerrores,_alfabetoIself) =+ alfabeto_ _alfabetoOalf + ( _inicioIerrores,_inicioIself) =+ inicio_ _inicioOalfabeto + ( _produccionesIerrores,_produccionesIprods) =+ producciones_ _produccionesOalfabeto _produccionesOprods + in ( _lhsOresultado))+-- Succesor ----------------------------------------------------+type Succesor = [Simbolo ]+-- cata+sem_Succesor :: Succesor ->+ T_Succesor +sem_Succesor list =+ (Prelude.foldr sem_Succesor_Cons sem_Succesor_Nil (Prelude.map sem_Simbolo list) )+-- semantic domain+type T_Succesor = ([String]) ->+ ( ([String]),Succesor )+sem_Succesor_Cons :: T_Simbolo ->+ T_Succesor ->+ T_Succesor +sem_Succesor_Cons hd_ tl_ =+ (\ _lhsIalfabeto ->+ (let _lhsOerrores :: ([String])+ _lhsOself :: Succesor + _tlOalfabeto :: ([String])+ _hdIself :: Simbolo + _hdIsimb :: String+ _tlIerrores :: ([String])+ _tlIself :: Succesor + _lhsOerrores =+ ({-# LINE 119 "./src/SistemaL.ag" #-}+ if elem _hdIsimb _lhsIalfabeto+ then _tlIerrores+ else ("El simbolo de la produccion (der): '" ++ _hdIsimb ++ "' no se encuentra en el alfabeto.") : _tlIerrores+ {-# LINE 477 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ (:) _hdIself _tlIself+ {-# LINE 482 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 487 "./src/SistemaL.hs" #-}+ )+ _tlOalfabeto =+ ({-# LINE 39 "./src/SistemaL.ag" #-}+ _lhsIalfabeto+ {-# LINE 492 "./src/SistemaL.hs" #-}+ )+ ( _hdIself,_hdIsimb) =+ hd_ + ( _tlIerrores,_tlIself) =+ tl_ _tlOalfabeto + in ( _lhsOerrores,_lhsOself)))+sem_Succesor_Nil :: T_Succesor +sem_Succesor_Nil =+ (\ _lhsIalfabeto ->+ (let _lhsOerrores :: ([String])+ _lhsOself :: Succesor + _lhsOerrores =+ ({-# LINE 122 "./src/SistemaL.ag" #-}+ []+ {-# LINE 507 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ []+ {-# LINE 512 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 517 "./src/SistemaL.hs" #-}+ )+ in ( _lhsOerrores,_lhsOself)))