LSystem.hs

LSystem.hs

{-# LANGUAGE OverloadedStrings #-}
module Main 
where
import Data.Aeson
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Data.Aeson (Value(..))
import qualified Data.HashMap.Strict as H
import Control.Applicative
import Control.Monad
import qualified Data.ByteString.Lazy.Char8 as B


-- What I have to use with generically derived instance
jsonInputGeneric =
    "[\
    \{\"contents\":\"b\",\"tag\":\"Follow\"},\
    \{\"contents\":\"B\",\"tag\":\"Var\"},\
    \{\"contents\":[\"r\",0.6],\"tag\":\"Scale\"},\
    \{\"contents\":[\"\\u003c\",0.14285714285714],\"tag\":\"Turn\"},\
    \{\"contents\":[\"\\u003e\",-0.14285714285714],\"tag\":\"Turn\"},\
    \{\"contents\":[\"s\",[[0,0],[0,1]]],\"tag\":\"Seed\"},\
    \{\"contents\":[\"R1\",\"br<,br>\"],\"tag\":\"Rule\"}\
    \]"

-- What I thought would be more easily read or written by a human.
-- A grammar element is identified by its name, which must be unique.
jsonInputForHumans :: B.ByteString
jsonInputForHumans =
    "[\
    \{\"b\":\"follow\"},\
    \{\"B\":\"var\"},\
    \{\"r\":{\"scale\":0.6}},\
    \{\"<\":{\"turn\":0.14285714285714}},\
    \{\">\":{\"turn\":-0.14285714285714}},\
    \{\"s\":{\"seed\":{\"p\":{\"x\":0,\"y\":0},\"v\":{\"x\":0,\"y\":1}}}},\
    \{\"R1\":{\"rule\": {\"B\": \"b r [ < B ] [ > B ]\"}}}\
    \]"

-- The grammar type.
-- For RuleVal, the Name is left-hand-side and is a variable; String is production rule.
-- The Turn, Scale, Follow, and Seed elements are all terminals. Seed is the type starting words.
type Name    = String
type SeedVal = ((Double, Double), (Double, Double))
type RuleVal = (Name, String)
type Grammar = [GrammarDef]
data GrammarDef = Var         Name
                | Turn        Name Double
                | Scale       Name Double
                | Follow      Name
                | Seed        Name SeedVal
                | Rule        Name RuleVal
    deriving (Show, Eq)


instance FromJSON GrammarDef where
  parseJSON (Object v) = 
    case (H.elems v) of
     [String "follow"] -> Follow <$> (pure . T.unpack .  head . H.keys $ v)
     [String "var"] -> Var <$> (pure . T.unpack .  head . H.keys $ v)
     [Object v'] -> 
        case (H.keys v') of
          ["scale"] -> 
              Scale <$> (pure . T.unpack . head . H.keys $ v) 
                    <*> (parseJSON . head . H.elems $ v')
          ["turn"] -> 
              Turn <$> (pure . T.unpack . head . H.keys $ v) 
                   <*> v' .: "turn"
          ["seed"] -> do
              let name = T.unpack . head . H.keys $ v
              vec <- (v' .: "seed") >>=  (.: "v")
              pt <- (v' .: "seed") >>= (.: "p")
              vec' <- (,) <$> vec .: "x" <*> vec .: "y"
              pt' <- (,) <$> pt .: "x" <*> pt .: "y"
              return $ Seed name (pt', vec')
          ["rule"] -> do
              let name = T.unpack . head . H.keys $ v
              rule <- v' .: "rule"
              let ruleValName = T.unpack . head . H.keys $ rule
              ruleValString <- parseJSON . head . H.elems $ rule
              return $ Rule name (ruleValName, ruleValString)
          _ -> mzero
     _ -> mzero


-- The generic solution.
{-
instance FromJSON GrammarDef
instance ToJSON GrammarDef
-}

-- The hardcoded solution (up to ordering).
grammar :: Grammar
grammar =
  [
      Follow "b"
    , Var    "B"
    , Scale  "r"  0.6
    , Turn   "<"  0.14285714285714
    , Turn   ">"  (-0.14285714285714)
    , Seed   "s"  ((0, 0), (0, 1))
    , Rule   "R1" ("B", "b r [ < B ] [ > B ]")
  ]

main = do
  putStrLn "input data:"
  putStrLn . B.unpack $ jsonInputForHumans
  putStrLn "target data:"
  putStrLn . show $ grammar
  let res = decode jsonInputForHumans :: Maybe [GrammarDef] 
  print res
  print $ fromJust res == grammar

I'm intrigued by all the magic behind the Generics approach. I know Data.Aeson has a way of generically deriving ToJSON and FromJSON instances from Haskell record data types as well. I've tried that approach in the past, but found that it reduced my options too much for how I wanted to define my core Haskell data types & also for how I wanted the JSON to look.