Monday, January 4, 2010

The Finite Groups programming language

Finite Groups is a programming language with a syntax that is intended to look somewhat mathematical. As a language, it is not very powerful, being essentially just a calculator -- every Finite Groups program halts. The data type is a list of group elements. The groups are cyclic groups, dihedral groups, symmetric groups, alternating groups, dicyclic groups, and cartesian products of groups.
Syntax

A short comment begins with < and ends with > and cannot contain < or >, and cannot be </code>. A short comment cannot be <sub> after a group name, and cannot be </sub> within a type name.

A long comment begins with </code> and ends with <code> or may continue to the end of the source. If there is any <code> in the source, then everything up to the first <code> is a comment.

A program consists of a single expression. The symbol i, with type C[i], is predefined as the program's input.

Expressions are

  • symbol - A lowercase letter, a value defined in an enclosing let expression, or "i".

  • constant - One or more strings enclosed with double quotes. Adjacent strings are concatenated. Backslash escapes can be used to include double quotes, backslashes, newlines, returns, tabs, vertical tabs, and form-feeds.

  • inverse - "-" followed by an expression.

  • product - An expression followed by another expression.

  • cartesian product - Two expressions separated by "*".

  • reduction - "!" followed by an expression.

  • left projection - "P" followed by an expression.

  • right projection - An expression followed by "P".

  • type name - A group name followed by "[", followed by one or more expressions, separated by ",", followed by "]" or two type names separated by "*".

  • permutation - "S", followed by "[", followed by two expressions separated by "->", followed by "]".

  • let - "let" followed by one or more bindings, followed by "in", followed by an expression.


Group names

  • "C" - cyclic group, "Z" is a synonym.

  • "D" - dihedral group, "Dih" is a synonym.

  • "S" - symmetric group.

  • "A" - alternating group.

  • "Dic" - dicyclic group.


A let binding is a symbol (a lower-case letter), followed by an optional type specification, followed by "=", followed by an expression. All preceding bindings are visible in the expression. The binding itself and any following bindings are not visible. The binding itself is visible in the type specification, but with the unspecified type of the expression.

A type specification is a ":", followed by a type name.

For even more mathematical appearances, the following synonyms are recognized:

  • !: &Pi;

  • [: <sub>

  • ]: </sub>

  • ->: &rarr;

  • *: &times;


Associativity

Associativity can be explicitly specified with parentheses.

Associativity is otherwise deliberately left undefined. For group products, since (ab)c = a(bc), associativity is irrelevant. For other operations, a sophisticated parser could use spacing to infer associativity. For example, !a b*c = (!a)(b*c), while !ab * c = (!(ab))*c or !ab * c = ((!a)b)*c. An even more sophisticated parser could use type analysis to rule out interpretations that would result in illegal code.
Types

A type is a group name and a list of expressions. The unique elements in the list of expressions, in order, are used to generate a group. Values of the type are lists of elements in that group.

  • C[expr] is a cyclic group. The first expr element is the identity.

  • D[expr] is a dihedral group. The first epxr element is the identity, and the remaining expr elements are the rotations.

  • S[expr] is a symmetric group. The group elements are the permutations of the expr elements.

  • A[expr] is an alternating group. The group elements are the even permutations of the expr elements.

  • Dic[expr] is a dicyclic group. The expr elements form a cyclic subgroup of the group, where the first expr element is the identity.


Values


  • constant - "string" has type C["string"]

  • inverse - Inverse of each element in the list

  • product - If the two values are of the same type, then if a = {a1,a2,a3...} and b = {b1,b2,b3...}, then ab = {a1b1,a1b2,a1b3...,a2b1...} with the group operation. If the left type is a permutation, and every value in the permutation is a value in the right type, then the right values are mapped by the permutation with the same distributivity as with the group operation, and the result has the type of the right type.

  • cartesian product - With the same distributivity as with the product, the type of the result is the product of the left and right types.

  • reduction - Results in a single element list by folding the elements in the list with the group operation.

  • left/right projection - The left/right projections of a cartesian product.

  • type name - A list with all the elements in the group in the group's natural order.

  • permutation - S[expr1->expr2] is a single element list of type S[expr1] that maps the elements of expr1 to the elements of expr2.


Examples

Hello world

"Hello world!\n"

cat

i

rot13

let a = "abcdefghijklmABCDEFGHIJKLMnopqrstuvwxyzNOPQRSTUVWXYZ"
r : C[a] = "n"
i : C[a,i] = i
in S[a->ra]i

touppercase

let t = !"01"
f = tt
a = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
u : C[a] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
l : C[a] = "abcdefghijklmnopqrstuvwxyz"
m = S["01"*a->C[f*u,t*u,f*l,t*l]]
i : C[a,i] = i
in (m(f*i))P

quaternions

let q = Dic"1-"
c : Cq = "-"
i : Dic"1-" = cc
j : Dic"1-" = cccc
k = ij
in k

Interpreter

This interpreter handles associativity by just doing whatever is easiest to parse. The parser also incorrectly disallows <sub> and </sub> comments in places where they should be allowed.

module FiniteGroup where

class FiniteGroup g where
identity :: g -> Integer
order :: g -> Integer
prod :: g -> Integer -> Integer -> Integer
inverse :: g -> Integer -> Integer
reduce :: g -> [Integer] -> Integer
elements :: g -> [Integer]

identity g = 0
reduce g is = foldl (prod g) (identity g) is
elements g = [0..order g - 1]

module Element where

import Data.List(elemIndex,(!!))

data Element =
Element Char
| DihReflectElement Element
| Permutation [Element]
| DicIElement Element
| DicJElement Element
| DicKElement Element
| DirProdElement Element Element
deriving (Eq,Ord)

instance Show Element where
show (Element c) = [c]
show (DihReflectElement e) = "<DRefl " ++ show e ++ ">"
show (Permutation e) = "<Perm " ++ concatMap show e ++ ">"
show (DicIElement e) = "<DicI " ++ show e ++ ">"
show (DicJElement e) = "<DicJ " ++ show e ++ ">"
show (DicKElement e) = "<DicK " ++ show e ++ ">"
show (DirProdElement e1 e2) = '<' : show e1 ++ '*' : show e2 ++ ">"

class Generated g where
generate :: [Element] -> g
generator :: g -> [Element]
generated :: g -> [Element]
elementIndex :: g -> Element -> Maybe Integer
elementIndex g elt = fmap fromIntegral (elemIndex elt (generated g))
element :: g -> Integer -> Element
element g i = generated g !! fromIntegral i

uniq :: Eq a => [a] -> [a]
uniq [] = []
uniq (a:as) = a : uniq (filter (/= a) as)

module Permutation(decodePermutation,encodePermutation,applyPermutation,inversePermutation,toPermutation) where

import Data.List(elemIndex)

encodePermutation :: [Integer] -> Integer
encodePermutation is = encode is 0 (fromIntegral (length is) - 1)

encode :: [Integer] -> Integer -> Integer -> Integer
encode [] e _ = e
encode (i:is) e n = encode (map (\ j -> if j > i then j - 1 else j) is)
(e + i*product [2..n]) (n - 1)

decodePermutation :: Integer -> Integer -> [Integer]
decodePermutation n e = decode n e id

decode :: Integer -> Integer -> (Integer -> Integer) -> [Integer]
decode 0 _ _ = []
decode 1 e expand = [expand e]
decode n e expand =
let (i,e') = e `divMod` product [2..n - 1]
expand' j = expand (if j >= i then j + 1 else j)
in expand i : decode (n - 1) e' expand'

applyPermutation :: [Integer] -> [a] -> [a]
applyPermutation is elements = map ((elements !!) . fromIntegral) is

inversePermutation :: [Integer] -> [Integer]
inversePermutation is = toPermutation is [0..fromIntegral (length is) - 1]

toPermutation :: Eq a => [a] -> [a] -> [Integer]
toPermutation src dest =
map (maybe (error "Permutation.toPermutation: invalid permutation")
fromIntegral . (`elemIndex` src))
dest

module CyclicGroup(CyclicGroup) where

import Element
import FiniteGroup

data CyclicGroup = CyclicGroup [Element]
deriving (Eq,Show)

instance FiniteGroup CyclicGroup where
identity _ = 0
order (CyclicGroup elements) = fromIntegral (length elements)
prod c i1 i2 = (i1 + i2) `mod` order c
inverse c i = (order c - i) `mod` order c

instance Generated CyclicGroup where
generate = CyclicGroup . uniq
generator (CyclicGroup elements) = elements
generated (CyclicGroup elements) = elements

module DihedralGroup(DihedralGroup) where

import Element
import FiniteGroup

data DihedralGroup = DihedralGroup [Element]
deriving (Eq,Show)

instance FiniteGroup DihedralGroup where
identity _ = 0
order d = 2 * size d
prod d i1 i2
| i1 < size d && i2 < size d = (i1 + i2) `mod` size d
| i1 < size d = size d + ((i1 + i2) `mod` size d)
| i2 < size d = size d + ((i1 - i2 + size d) `mod` size d)
| otherwise = (i1 - i2 + size d) `mod` size d
inverse d i | i >= size d = i
| otherwise = (size d - i) `mod` size d

instance Generated DihedralGroup where
generate = DihedralGroup . uniq
generator (DihedralGroup rotations) = rotations
generated (DihedralGroup rotations) =
rotations ++ map DihReflectElement rotations

size :: DihedralGroup -> Integer
size (DihedralGroup rotations) = fromIntegral (length rotations)

module DicyclicGroup(DicyclicGroup) where

import Element
import FiniteGroup

data DicyclicGroup = DicyclicGroup [Element]
deriving (Eq,Show)

instance FiniteGroup DicyclicGroup where
identity _ = 0
order d = 4*size d
prod d i1 i2 =
let n = size d
(k1,j1) = decode n i1
(k2,j2) = decode n i2
in encode n ((k1 + k2 - j1*(2*k2) + (2 + j2)*n) `mod` (2*n))
((j1 + j2) `mod` 2)
inverse d i =
let n = size d
(k,j) = decode n i
in encode n ((2*n - k + j*n) `mod` (2*n)) j

instance Generated DicyclicGroup where
generate = DicyclicGroup . uniq
generator (DicyclicGroup elements) = elements
generated (DicyclicGroup elements) =
elements ++ map DicIElement elements
++ map DicJElement elements ++ map DicKElement elements

size :: DicyclicGroup -> Integer
size (DicyclicGroup elements) = fromIntegral (length elements)

encode :: Integer -> Integer -> Integer -> Integer
encode n k j = 2*(k `mod` n) + ((k `div` n) `mod` 2) + 2*n*j

decode :: Integer -> Integer -> (Integer,Integer)
decode n i = ((i `div` 2) + n*(i `mod` 2), i `div` (2*n))

module SymmetricGroup(SymmetricGroup) where

import Data.List(sort)

import Element
import FiniteGroup
import Permutation

data SymmetricGroup = SymmetricGroup [Element]
deriving (Eq,Show)

instance FiniteGroup SymmetricGroup where
identity _ = 0
order s = product [2..size s]
prod s i1 i2 =
encodePermutation (applyPermutation (decodePermutation (size s) i1)
(decodePermutation (size s) i2))
inverse s i =
encodePermutation (inversePermutation (decodePermutation (size s) i))

instance Generated SymmetricGroup where
generate = SymmetricGroup . sort . uniq
generator (SymmetricGroup elements) = elements
generated s = map (element s) (elements s)
element g i = Permutation (applyPermutation (decodePermutation (size g) i)
(generator g))
elementIndex g (Permutation e) =
if fromIntegral (length e) == size g && all (`elem` e) (generator g)
then Just (encodePermutation (toPermutation (generator g) e))
else Nothing

size :: SymmetricGroup -> Integer
size (SymmetricGroup elements) = fromIntegral (length elements)

module AlternatingGroup(AlternatingGroup) where

import Data.List(sort)

import Element
import FiniteGroup
import Permutation

data AlternatingGroup = AlternatingGroup [Element]
deriving (Eq,Show)

instance FiniteGroup AlternatingGroup where
identity _ = 0
order a = product [3..size a]
prod a i1 i2 =
encodePermutation (applyPermutation (decodePermutation (size a) (2*i1))
(decodePermutation (size a)
(2*i2)))
`div` 2
inverse a i =
encodePermutation (inversePermutation (decodePermutation (size a)
(2*i)))
`div` 2

instance Generated AlternatingGroup where
generate = AlternatingGroup . sort . uniq
generator (AlternatingGroup elements) = elements
generated g = map (element g) (elements g)
element g i = Permutation (applyPermutation (decodePermutation (size g)
(2*i))
(generator g))
elementIndex g (Permutation e) =
if fromIntegral (length e) == size g && all (`elem` e) (generator g)
then let i = encodePermutation (toPermutation (generator g) e)
in if i `mod` 2 == 0
then Just (i `div` 2)
else Nothing
else Nothing

size :: AlternatingGroup -> Integer
size (AlternatingGroup elements) = fromIntegral (length elements)

module Expr where

data Expr =
Symbol String Char
| Inverse String Expr
| Reduce String Expr
| LeftProjection String Expr
| RightProjection String Expr
| Constant String String
| Prod String Expr Expr
| DirProd String Expr Expr
| Let String [Binding] Expr
| Constructor String TypeName
| Permutation String Expr Expr
deriving Show

data TypeName =
Cyclic [Expr]
| Dihedral [Expr]
| Symmetric [Expr]
| Alternating [Expr]
| Dicyclic [Expr]
| DirectProduct TypeName TypeName
deriving Show

data Binding = Binding String Char (Maybe TypeName) Expr
deriving Show

module Parser(parse) where

import Text.ParserCombinators.Parsec(CharParser,anyChar,eof,getPosition,getState,many,many1,manyTill,notFollowedBy,oneOf,noneOf,optionMaybe,runParser,sepBy1,setState,sourceColumn,sourceLine,sourceName,space,try,(<|>),(<?>))
import qualified Text.ParserCombinators.Parsec as Parsec

import Expr

type Parser a = CharParser [Bool] a

parse :: String -> String -> Expr
parse file src = either (error . show) id (runParser program [] file src)

srcLocation :: Parser String
srcLocation =
let format p = sourceName p ++ ':' : show (sourceLine p)
++ ':' : show (sourceColumn p)
in fmap format getPosition

enterLet :: Parser ()
enterLet = getState >>= setState . (True:)

exitLet :: Parser ()
exitLet = getState >>= setState . tail

enterBracketed :: Parser ()
enterBracketed = getState >>= setState . (False:)

exitBracketed :: Parser ()
exitBracketed = getState >>= setState . tail

inLet :: Parser Bool
inLet = fmap (and . (flip map [not . null, head]) . flip ($)) getState

ignore :: Parser a -> Parser ()
ignore = (>> return ())

skipSpace :: Parser ()
skipSpace = ignore (many (ignore space <|> comment))

comment :: Parser ()
comment = (try (Parsec.string "</code>") >> endComment (return ()))
<|> (try (Parsec.char '<'
>> notFollowedBy (try (Parsec.string "sub>") >> return '<')
>> notFollowedBy (try (Parsec.string "/sub>") >> return '<')
>> manyTill (noneOf "<>") (Parsec.char '>')
>> return ()))

endComment :: Parser () -> Parser ()
endComment onEOF = (try (Parsec.string "<code>") >> return ())
<|> (eof >> onEOF)
<|> (anyChar >> endComment onEOF)

program :: Parser Expr
program = do
try (endComment (fail "No comments")) <|> return ()
skipSpace
expr

-- applicative
f <$> a = fmap f a
f <*> a = f >>= (<$> a)
a <$ b = b >> return a
a *> b = a >> b
a <* b = const <$> a <*> b
infixl 4 <$>
infixl 4 <*>
infixl 4 <$
infixl 4 *>
infixl 4 <*

expr :: Parser Expr
expr = do
watchingForIn <- inLet
if watchingForIn
then optionMaybe (string "in")
>>= maybe (return ()) (const (fail "in"))
else return ()
expr1

expr1 :: Parser Expr
expr1 = simpleExpr >>= applyRight >>= applyProduct

simpleExpr :: Parser Expr
simpleExpr =
char '(' *> enterBracketed *> expr1 <* char ')' <* exitBracketed
-- let must be tried before symbol
<|> try (Let <$> srcLocation <*> (string "let" *> bindings) <*> expr1)
<|> Symbol <$> srcLocation
<*> try (oneOf ['a'..'z'] <* skipSpace
<* notFollowedBy (oneOf ":="))
-- try in case it's ->
<|> try (apply Inverse (char '-'))
<|> apply Reduce (char '!' <|> string "&Pi;")
<|> apply LeftProjection (char 'P')
<|> Constant <$> srcLocation <*> (concat <$> many1 stringConst)
-- try in case it's an S constructor
<|> try (Permutation <$> srcLocation
<*> (char 'S' *> openBracket *> expr1)
<*> (arrow *> expr1 <* closeBracket))
<|> Constructor <$> srcLocation <*> typeName

char :: Char -> Parser ()
char c = Parsec.char c *> skipSpace

string :: String -> Parser ()
string str = try (Parsec.string str) *> skipSpace

apply :: (String -> Expr -> Expr) -> Parser op -> Parser Expr
apply op parseOp = op <$> srcLocation <*> (parseOp *> expr1)

applyRight :: Expr -> Parser Expr
applyRight exp = do
loc <- srcLocation
char 'P' *> applyRight (RightProjection loc exp) <|> return exp

applyProduct :: Expr -> Parser Expr
applyProduct exp =
flip DirProd exp <$> srcLocation <*> (times *> expr1)
<|> flip Prod exp <$> srcLocation <*> try expr
<|> return exp

stringConst :: Parser String
stringConst =
Parsec.char '"' *> many stringChar <* Parsec.char '"' <* skipSpace

stringChar :: Parser Char
stringChar = noneOf "\r\n\\\""
<|> try (Parsec.string "\\t") *> return '\t'
<|> try (Parsec.string "\\v") *> return '\v'
<|> try (Parsec.string "\\f") *> return '\f'
<|> try (Parsec.string "\\r") *> return '\r'
<|> try (Parsec.string "\\n") *> return '\n'
<|> try (Parsec.string "\\\\") *> return '\\'
<|> try (Parsec.string "\\\"") *> return '"'

openBracket :: Parser ()
openBracket = (char '[' <|> string "<sub>") *> enterBracketed

closeBracket :: Parser ()
closeBracket = (char ']' <|> string "</sub>") *> exitBracketed

arrow :: Parser ()
arrow = string "->" <|> string "&rarr;"

times :: Parser ()
times = char '*' <|> string "&times;"

bindings :: Parser [Binding]
bindings = enterLet *> manyTill binding (string "in") <* exitLet

binding :: Parser Binding
binding =
Binding <$> srcLocation
<*> oneOf ['a'..'z'] <* skipSpace
<*> optionMaybe (char ':' *> typeName)
<*> (char '=' *> expr1)

typeName :: Parser TypeName
typeName = do
t <- simpleTypeName
try (times *> (DirectProduct t <$> typeName)) <|> return t

simpleTypeName :: Parser TypeName
simpleTypeName = Cyclic <$> (char 'C' *> typeArgs)
<|> Cyclic <$> (char 'Z' *> typeArgs)
<|> Symmetric <$> (char 'S' *> typeArgs)
<|> Alternating <$> (char 'A' *> typeArgs)
<|> Dicyclic <$> (string "Dic" *> typeArgs)
<|> Dihedral <$> (string "Dih" *> typeArgs)
<|> Dihedral <$> (char 'D' *> typeArgs)

typeArgs :: Parser [Expr]
typeArgs = openBracket *> sepBy1 expr1 (char ',') <* closeBracket

module Value where

import Data.List(sort)

import Element
import CyclicGroup
import DihedralGroup
import SymmetricGroup
import AlternatingGroup
import DicyclicGroup
import qualified FiniteGroup as FG
import Permutation

data Type =
CyclicType CyclicGroup
| DihedralType DihedralGroup
| SymmetricType SymmetricGroup
| AlternatingType AlternatingGroup
| DicyclicType DicyclicGroup
| DirectProductType Type Type
deriving (Eq,Show)

data Value = Value [Integer] Type
deriving (Eq,Show)

order :: Type -> Integer
order (CyclicType g) = FG.order g
order (DihedralType g) = FG.order g
order (SymmetricType g) = FG.order g
order (AlternatingType g) = FG.order g
order (DicyclicType g) = FG.order g
order (DirectProductType t1 t2) = order t1 * order t2

projections :: Value -> (Value,Value)
projections (Value elts (DirectProductType t1 t2)) =
(Value (map (`div` order t2) elts) t1,Value (map (`mod` order t2) elts) t2)

directZip :: Value -> Value -> Value
directZip (Value e1 t1) (Value e2 t2) =
Value (zipWith (+) (map (order t2 *) e1) e2) (DirectProductType t1 t2)

inverse :: Value -> Value
inverse (Value elts t@(CyclicType g)) = Value (map (FG.inverse g) elts) t
inverse (Value elts t@(DihedralType g)) = Value (map (FG.inverse g) elts) t
inverse (Value elts t@(SymmetricType g)) = Value (map (FG.inverse g) elts) t
inverse (Value elts t@(AlternatingType g)) = Value (map (FG.inverse g) elts) t
inverse (Value elts t@(DicyclicType g)) = Value (map (FG.inverse g) elts) t
inverse v@(Value _ t@(DirectProductType _ _)) =
let (v1,v2) = projections v in directZip (inverse v1) (inverse v2)

reduce :: Value -> Value
reduce (Value elts t@(CyclicType g)) = Value [FG.reduce g elts] t
reduce (Value elts t@(DihedralType g)) = Value [FG.reduce g elts] t
reduce (Value elts t@(SymmetricType g)) = Value [FG.reduce g elts] t
reduce (Value elts t@(AlternatingType g)) = Value [FG.reduce g elts] t
reduce (Value elts t@(DicyclicType g)) = Value [FG.reduce g elts] t
reduce v@(Value _ t@(DirectProductType _ _)) =
let (v1,v2) = projections v in directZip (reduce v1) (reduce v2)

leftProjection :: (String -> Value) -> Value -> Value
leftProjection _ v@(Value _ t@(DirectProductType _ _)) = fst (projections v)
leftProjection err _ = err "Invalid left projection"

rightProjection :: (String -> Value) -> Value -> Value
rightProjection _ v@(Value _ t@(DirectProductType _ _)) = snd (projections v)
rightProjection err _ = err "Invalid right projection"

prod :: (String -> Value) -> Value -> Value -> Value
prod err v1@(Value e1 t1) v2@(Value e2 t2)
| t1 == t2 = Value [ elemProd t1 i1 i2 | i1 <- e1, i2 <- e2 ] t1
| t1 `appliesTo` t2 =
fromElements err t2
[ mapElement t1 i1 elt2 | i1 <- e1, elt2 <- toElements v2 ]
| otherwise = err "Type mismatch"

dirProd :: Value -> Value -> Value
dirProd (Value e1 t1) (Value e2 t2) =
Value [ i1*(order t2) + i2 | i1 <- e1, i2 <- e2 ] (DirectProductType t1 t2)

elemProd (CyclicType g) i1 i2 = FG.prod g i1 i2
elemProd (DihedralType g) i1 i2 = FG.prod g i1 i2
elemProd (SymmetricType g) i1 i2 = FG.prod g i1 i2
elemProd (AlternatingType g) i1 i2 = FG.prod g i1 i2
elemProd (DicyclicType g) i1 i2 = FG.prod g i1 i2
elemProd (DirectProductType t1 t2) i j =
let (i1,i2) = i `divMod` order t2
(j1,j2) = j `divMod` order t2
in order t2 * elemProd t1 i1 j1 + elemProd t2 i2 j2

appliesTo :: Type -> Type -> Bool
appliesTo (SymmetricType g) t =
all (`elem` toElements (constructorValue t)) (generator g)
appliesTo (AlternatingType g) t =
all (`elem` toElements (constructorValue t)) (generator g)
appliesTo _ _ = False

mapElement :: Type -> Integer -> Element -> Element
mapElement (SymmetricType g) i elt =
let (Permutation dest) = element g i
in maybe elt id (lookup elt (zip (generator g) dest))
mapElement (AlternatingType g) i elt =
let (Permutation dest) = element g i
in maybe elt id (lookup elt (zip (generator g) dest))

mapToType :: (String -> Value) -> Value -> Type -> Value
mapToType err v t = fromElements err t (toElements v)

constructorValue :: Type -> Value
constructorValue t = Value [0..fromIntegral (order t) - 1] t

toElements :: Value -> [Element]
toElements (Value es t) = map (typeElement t) es

typeElement :: Type -> Integer -> Element
typeElement (CyclicType g) i = element g i
typeElement (DihedralType g) i = element g i
typeElement (SymmetricType g) i = element g i
typeElement (AlternatingType g) i = element g i
typeElement (DicyclicType g) i = element g i
typeElement (DirectProductType t1 t2) i =
let (i1,i2) = i `divMod` order t2
in DirProdElement (typeElement t1 i1) (typeElement t2 i2)

fromElements :: (String -> Value) -> Type -> [Element] -> Value
fromElements err t elements =
maybe (err "Value does not match type") (flip Value t)
(sequence (map (typeElementIndex t) elements))

typeElementIndex :: Type -> Element -> Maybe Integer
typeElementIndex (CyclicType g) e = elementIndex g e
typeElementIndex (DihedralType g) e = elementIndex g e
typeElementIndex t@(SymmetricType g) e = widenMap t e >>= elementIndex g
typeElementIndex t@(AlternatingType g) e = widenMap t e >>= elementIndex g
typeElementIndex (DicyclicType g) e = elementIndex g e
typeElementIndex (DirectProductType t1 t2) (DirProdElement e1 e2) = do
i1 <- typeElementIndex t1 e1
i2 <- typeElementIndex t2 e2
return (i1 * order t2 + i2)

permutation :: (String -> Value) -> Value -> Value -> Value
permutation err v1 v2 =
let e1 = uniq (toElements v1)
e2 = uniq (toElements v2)
g = generate e1
e = generator g
perm = applyPermutation (toPermutation e1 e) (toPermutation e e2)
in if e == sort e2
then Value [encodePermutation perm] (SymmetricType g)
else err "Invalid mapping"

widenMap :: Type -> Element -> Maybe Element
widenMap (SymmetricType g) (Permutation elts) =
if all (`elem` generator g) elts
then Just (Permutation (widenPermutation (generator g) elts))
else Nothing
widenMap (AlternatingType g) (Permutation elts) =
if all (`elem` generator g) elts
then Just (Permutation (widenPermutation (generator g) elts))
else Nothing
widenMap _ _ = Nothing

widenPermutation :: [Element] -> [Element] -> [Element]
widenPermutation widenedElts elts =
map (\ e -> maybe e id (lookup e (zip (sort elts) elts))) widenedElts

module Interp(eval,interp) where

import Data.List(elemIndex,sort,(!!))

import Element
import Expr
import Value

interp :: Expr -> String -> String
interp expr input = toString (eval [('i',fromString input)] expr)

eval :: [(Char,Value)] -> Expr -> Value
eval bindings (Symbol loc c) =
maybe (err loc ("Undefined symbol: " ++ [c])) id (lookup c bindings)
eval bindings (Inverse _ expr) = inverse (eval bindings expr)
eval bindings (Reduce _ expr) = reduce (eval bindings expr)
eval bindings (LeftProjection loc expr) =
leftProjection (err loc) (eval bindings expr)
eval bindings (RightProjection loc expr) =
rightProjection (err loc) (eval bindings expr)
eval bindings (Constant _ str) = fromString str
eval bindings (Prod loc l r) =
prod (err loc) (eval bindings l) (eval bindings r)
eval bindings (DirProd _ l r) = dirProd (eval bindings l) (eval bindings r)
eval bindings (Let _ bindList expr) = eval (bind bindings bindList) expr
eval bindings (Constructor _ typeName) = constructor bindings typeName
eval bindings (Expr.Permutation loc l r) =
permutation (err loc) (eval bindings l) (eval bindings r)

err :: String -> String -> a
err loc msg = error (loc ++ ": " ++ msg)

cast :: (String -> Value) -> [(Char,Value)] -> Char
-> TypeName -> Value -> Value
cast err bindings c typeName value =
mapToType err value (makeType ((c,value):bindings) typeName)

constructor :: [(Char,Value)] -> TypeName -> Value
constructor bindings typeName = constructorValue (makeType bindings typeName)

makeType :: [(Char,Value)] -> TypeName -> Type
makeType bindings (Cyclic exprs) =
CyclicType (generate (makeTypeElements bindings exprs))
makeType bindings (Dihedral exprs) =
DihedralType (generate (makeTypeElements bindings exprs))
makeType bindings (Symmetric exprs) =
SymmetricType (generate (makeTypeElements bindings exprs))
makeType bindings (Alternating exprs) =
AlternatingType (generate (makeTypeElements bindings exprs))
makeType bindings (Dicyclic exprs) =
DicyclicType (generate (makeTypeElements bindings exprs))
makeType bindings (DirectProduct t1 t2) =
DirectProductType (makeType bindings t1) (makeType bindings t2)

makeTypeElements :: [(Char,Value)] -> [Expr] -> [Element]
makeTypeElements bindings exprs =
concatMap toElements (map (eval bindings) exprs)

bind :: [(Char,Value)] -> [Binding] -> [(Char,Value)]
bind bindings [] = bindings
bind bindings ((Binding loc char typeName expr):bindList) =
bind ((char,maybe id (cast (err loc) bindings char) typeName
(eval bindings expr))
: bindings)
bindList

fromString :: String -> Value
fromString str =
let elements = map Element str
in fromElements error (CyclicType (generate elements)) elements

toString :: Value -> String
toString v = concatMap show (toElements v)

module Main(main) where

import Interp(interp)
import Parser(parse)
import System.Environment(getArgs)

main :: IO ()
main = do
(filename:_) <- getArgs
fmap (interp . parse filename) (readFile filename) >>= interact

No comments:

Post a Comment