Changeset 1390


Ignore:
Timestamp:
Oct 30, 2011, 5:08:39 PM (6 years ago)
Author:
joerg
Message:

improved trees

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/scripting/haskell/Trees.hs

    r1389 r1390  
    3131} deriving (Eq, Show)
    3232
     33data Config = Config {
     34    node_sep :: Double
     35  , edge_sep :: Double
     36} deriving (Eq, Show)
     37
     38defaultConfig = Config {
     39    node_sep = 0.5
     40  , edge_sep = 0.2
     41}
     42
    3343main :: IO ()
    3444main = do args <- getArgs
     
    3848    case Trees.parse string of
    3949      Left errors -> hPutStrLn stderr $ show errors
    40       Right (term,highlights) -> do
     50      Right (config,term,highlights) -> do
    4151        hPutStrLn stdout $ renderTerm term
    4252        hPutStr stdout $ "\\begin{pgfonlayer}{background}"
    4353        hPutStrLn stdout $ concat $ map (\h ->
    44           "\n  " ++ renderHighlight term h) highlights
     54          "\n  " ++ renderHighlight config term h) highlights
    4555        hPutStrLn stdout $ "\\end{pgfonlayer}"
    4656
     
    5161  "node" ++ propNode term ++ " (" ++ name term ++ ") {" ++ root term ++ "}" ++
    5262  (replace "\n" "\n  " $
    53     concat $ map (\child -> "\n  " ++ propBeforeChild term ++ "child" ++ propAfterChild term ++
     63    concat $ map (\child -> "\n  " ++ propBeforeChild child ++ "child" ++ propAfterChild child ++
    5464                            " { " ++ renderTerm_ child ++ "\n}") $ subterms term)
    5565
     
    98108      (tail nodes ++ [head nodes])
    99109
    100 north_east n = "($(" ++ n ++ ".north east) + (.4mm,-.4mm)$)"
    101 north_west n = "($(" ++ n ++ ".north west) + (-.4mm,-.4mm)$)"
    102 south_east n = "($(" ++ n ++ ".south east) + (.4mm,.4mm)$)"
    103 south_west n = "($(" ++ n ++ ".south west) + (-.4mm,.4mm)$)"
    104 south n = "($(" ++ n ++ ".south) + (0mm,-1mm)$)"
    105 north n = "($(" ++ n ++ ".north) + (0mm,1mm)$)"
    106 west n = "($(" ++ n ++ ".west) + (-1mm,0mm)$)"
    107 east n = "($(" ++ n ++ ".east) + (1mm,0mm)$)"
    108 on_way_left p n = "($(" ++ p ++ ") !.15! 270:(" ++ n ++ ") !.4! (" ++ n ++ ")$)"
    109 on_way_right p n = "($(" ++ p ++ ") !.15! 90:(" ++ n ++ ") !.4! (" ++ n ++ ")$)"
    110 
    111 renderHighlight :: Term -> Highlight -> String
    112 renderHighlight tree highlight =
     110north_east c n = "($(" ++ n ++ ".north east) + " ++ (show $ node_sep c) ++ "*(.4mm,.4mm)$)"
     111north_west c n = "($(" ++ n ++ ".north west) + " ++ (show $ node_sep c) ++ "*(-.4mm,.4mm)$)"
     112south_east c n = "($(" ++ n ++ ".south east) + " ++ (show $ node_sep c) ++ "*(.4mm,-.4mm)$)"
     113south_west c n = "($(" ++ n ++ ".south west) + " ++ (show $ node_sep c) ++ "*(-.4mm,-.4mm)$)"
     114south c n = "($(" ++ n ++ ".south) + " ++ (show $ node_sep c) ++ "*(0mm,-1mm)$)"
     115north c n = "($(" ++ n ++ ".north) + " ++ (show $ node_sep c) ++ "*(0mm,1mm)$)"
     116west c n = "($(" ++ n ++ ".west) + " ++ (show $ node_sep c) ++ "*(-1mm,0mm)$)"
     117east c n = "($(" ++ n ++ ".east) + " ++ (show $ node_sep c) ++ "*(1mm,0mm)$)"
     118on_way_left c p n = "($(" ++ p ++ ") !" ++ (show $ edge_sep c) ++ "! 270:(" ++ n ++ ") !.4! (" ++ n ++ ")$)"
     119on_way_right c p n = "($(" ++ p ++ ") !" ++ (show $ edge_sep c) ++ "! 90:(" ++ n ++ ") !.4! (" ++ n ++ ")$)"
     120
     121renderHighlight :: Config -> Term -> Highlight -> String
     122renderHighlight c tree highlight =
    113123  let root = head $ nodes highlight
    114124      lst = last $ nodes highlight
     
    117127  -- root
    118128  (if depth_lr lst tree <= depth_lr root tree
    119    then south_east root ++ " -- "
    120    else east root ++ " -- ") ++
    121   north_east root ++ " -- " ++ north root ++ " -- " ++
     129   then south_east c root ++ " -- "
     130   else east c root ++ " -- ") ++
     131  north_east c root ++ " -- " ++ north c root ++ " -- " ++
    122132  -- remaining path
    123   renderHighlight_ tree (up_down tree $ nodes highlight)
    124 
    125 renderHighlight_ tree [] = "cycle;"
    126 renderHighlight_ tree ((pn,d1,n,d2,nn):ns) =
     133  renderHighlight_ c tree (up_down tree $ nodes highlight)
     134
     135renderHighlight_ c tree [] = "cycle;"
     136renderHighlight_ c tree ((pn,d1,n,d2,nn):ns) =
    127137  (case d1 of
    128138     Inc ->  (if depth_lr pn tree >= depth_lr n tree
    129                then north_west n ++ " -- "
    130                else west n ++ " -- ") ++
     139               then north_west c n ++ " -- "
     140               else west c n ++ " -- ") ++
    131141             case d2 of
    132142               Inc -> if depth_lr nn tree >= depth_lr n tree
    133                       then south_west n ++ " -- "
     143                      then south_west c n ++ " -- "
    134144                      else if depth_lr pn tree >= depth_lr n tree
    135                            then west n ++ " -- "
     145                           then west c n ++ " -- "
    136146                           else ""
    137                Eq   -> south_west n ++ " -- " ++ south n ++ " -- " ++ south_east n ++ " -- "
    138                Dec   -> south_west n ++ " -- " ++ south n ++ " -- " ++ south_east n ++ " -- " ++
    139                         if depth_lr n tree >= depth_lr nn tree
    140                         then north_east n ++ " -- "
    141                         else ""
    142              ++ on_way_left n nn ++ " -- " ++ on_way_right nn n ++ " -- "
    143      Eq  ->  south_west n ++ " -- " ++
     147               Eq  -> south_west c n ++ " -- " ++ south c n ++ " -- " ++ south_east c n ++ " -- "
     148               Dec -> south_west c n ++ " -- " ++ south c n ++ " -- " ++ south_east c n ++ " -- " ++
     149                      if depth_lr n tree >= depth_lr nn tree
     150                      then north_east c n ++ " -- "
     151                      else ""
     152             ++ on_way_left c n nn ++ " -- " ++ on_way_right c nn n ++ " -- "
     153     Eq  ->  south_west c n ++ " -- " ++
    144154             case d2 of
    145155               Inc -> ""
    146                Eq   -> south n ++ " -- " ++ south_east n ++ " -- "
    147                Dec   -> south n ++ " -- " ++ south_east n ++ " -- " ++ north_east n ++ " -- "
    148              ++ on_way_left n nn ++ " -- " ++ on_way_right nn n ++ " -- "
     156               Eq  -> south c n ++ " -- " ++ south_east c n ++ " -- "
     157               Dec -> south c n ++ " -- " ++ south_east c n ++ " -- " ++
     158                      if depth_lr n tree >= depth_lr nn tree
     159                      then north_east c n ++ " -- "
     160                      else east c n ++ " -- "
     161             ++ on_way_left c n nn ++ " -- " ++ on_way_right c nn n ++ " -- "
    149162     Dec ->  case d2 of
    150163               Inc -> ""
    151                Eq  -> south_east n ++ " -- "
     164               Eq  -> south_east c n ++ " -- "
    152165               Dec -> if depth_lr pn tree <= depth_lr n tree
    153                       then south_east n ++ " -- "
    154                       else east n ++ " -- " ++
     166                      then south_east c n ++ " -- " ++
    155167                           if depth_lr n tree >= depth_lr nn tree
    156                            then north_east n ++ " -- "
     168                           then north_east c n ++ " -- "
     169                           else east c n ++ " -- "
     170                      else east c n ++ " -- " ++
     171                           if depth_lr n tree >= depth_lr nn tree
     172                           then north_east c n ++ " -- "
    157173                           else ""
    158              ++ on_way_left n nn ++ " -- " ++ on_way_right nn n ++ " -- "
    159   ) ++ renderHighlight_ tree ns
     174             ++ on_way_left c n nn ++ " -- " ++ on_way_right c nn n ++ " -- "
     175  ) ++ renderHighlight_ c tree ns
    160176
    161177-- || not (nested p n tree)
     
    184200symbol        = T.symbol lexer
    185201natural       = T.natural lexer
     202float         = T.float lexer
    186203parens        = T.parens lexer
    187204semi          = T.semi lexer
     
    210227getName name = foldr (\c s -> replace c "" s) name ["(",")","[","]","{","}","\\","$"] 
    211228
    212 parseInput :: Parser  (Term,[Highlight])
     229parseInput :: Parser (Config,Term,[Highlight])
    213230parseInput = do
    214231  whiteSpace
     232  config <- parseConfig <|> return defaultConfig
    215233  term <- parseTerm
    216234  highlights <- many parseHighlight
    217   return (term,highlights)
     235  return (config,term,highlights)
    218236 
    219237parseTerm :: Parser Term
     
    222240  pac <- parseOption
    223241  root <- identifier
    224   name <- (try $ do constant "@"; n <- identifier; return n) <|> return (getName root)
     242  name <- (try $ do constant ":"; n <- identifier; return n) <|> return (getName root)
    225243  pn <- parseOption
    226244  subterms <- try (parens $ sepBy parseTerm (constant ",")) <|> return []
     
    243261  nodes <- parens $ sepBy identifier (constant ",")
    244262  return $ Highlight { nodes = nodes, style = style }
     263
     264parseConfig :: Parser Config
     265parseConfig = do
     266  constant "<"
     267  options <- sepBy parseConfigOption (constant ",")
     268  constant ">"
     269  return $ foldr (\(n,v) c -> case n of
     270                                  "node_sep" -> c { node_sep = v }
     271                                  "edge_sep" -> c { edge_sep = v }
     272                                  otherwise  -> c) defaultConfig options
     273
     274parseConfigOption :: Parser (String,Double)
     275parseConfigOption = do
     276  name <- identifier
     277  constant "="
     278  value <- float
     279  return (name,value)
Note: See TracChangeset for help on using the changeset viewer.