diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -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 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ + +import Distribution.Simple + +main :: IO() +main = defaultMain + diff --git a/db/db.sl b/db/db.sl new file mode 100644 --- /dev/null +++ b/db/db.sl @@ -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] + ] + + } + diff --git a/lsystem.cabal b/lsystem.cabal new file mode 100644 --- /dev/null +++ b/lsystem.cabal @@ -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 diff --git a/src/GenSequences.hs b/src/GenSequences.hs new file mode 100644 --- /dev/null +++ b/src/GenSequences.hs @@ -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) + + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 + diff --git a/src/ParserLS.hs b/src/ParserLS.hs new file mode 100644 --- /dev/null +++ b/src/ParserLS.hs @@ -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 diff --git a/src/Process.hs b/src/Process.hs new file mode 100644 --- /dev/null +++ b/src/Process.hs @@ -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." + diff --git a/src/SistemaL.ag b/src/SistemaL.ag new file mode 100644 --- /dev/null +++ b/src/SistemaL.ag @@ -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 +} diff --git a/src/SistemaL.hs b/src/SistemaL.hs new file mode 100644 --- /dev/null +++ b/src/SistemaL.hs @@ -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)))