Created
May 28, 2014 03:11
-
-
Save danchoi/4a2a5d04821475684178 to your computer and use it in GitHub Desktop.
LSystem.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# 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.
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Nice job, more in the spirit of attoparsec than what I was doing, which involved a lot of error messages. Thanks.
I wonder, if I had defined Grammar as [(Name, GrammarDef)] where GrammarDef elements omit the name, if the generic encoding would be any nicer. I only use Grammar as a serialization of the mapping from name to element.