home *** CD-ROM | disk | FTP | other *** search
/ ftp.uni-stuttgart.de/pub/systems/acorn/ / Acorn.tar / Acorn / acornet / dev / gofer.spk / scripts / Group < prev    next >
Text File  |  1994-02-28  |  5KB  |  168 lines
  1.            ----------------- Groups -----------------
  2.  
  3. {- This script enables manipulations with groups, in particular
  4.    with F2, the free group on x,y. 
  5.  
  6.    Notation for group elements:
  7.  
  8.    x,y are generators of F2.
  9.    x' is inverse of x, y' is inverse of y.
  10.    g*h  is product of g and h.
  11.    (invert g) is inverse of g.
  12.    product [g1,...,gn] is product g1*...*gn.
  13.    g^n  is n-th power of g, for n>=0.
  14.    g^^h is conjugate of g by h, (invert h)*g*h.
  15.    g >< h is the commutator (invert g)*(invert h)*g*h.
  16.  
  17.    show <expression> prettyprints the group expression.
  18.  
  19. -}
  20.  
  21. t,j,s :: AutF2         -- 3 particular automorphisms of F2.
  22. t = endo (y,x)         -- t defined by (x,y) --> (y,x)
  23. j = endo (x',y)        -- j defined by (x,y) --> (x',y)
  24. s = endo (x',x'*y)     -- s defined by (x,y) --> (x',x'*y)
  25.  
  26. {- These 3 endomorphisms, each of order 2, generate the automorphism
  27.    group AutF2 of F2. 
  28.  
  29.    t,j generate the dihedral group D8. (t*j)^4 == 1. 
  30.    s,t generate the dihedral group D6. (s*t)^3 == 1. 
  31.    Only s alters any word lengths. s*j has infinite order.
  32.  
  33.    endo (w1,w2) gives the endomorphism of F2 induced by 
  34.    \(x,y)->(w1,w2).
  35.  
  36.    show <endomorphism> shows the effect on x and on y.
  37.  
  38.  -}
  39.  
  40. ------ infix declarations ----------------------------------------
  41.  
  42. infixr 8 ^^,><    -- conjugation, commutator
  43.  
  44. ----- datatypes and synonyms -------------------------------------
  45.  
  46. type F2      = Word Char
  47. type AutF2   = F2 -> F2
  48.  
  49. data Gen a = P a | N a        -- P "positive", N "negative" generators.
  50. data Word a = W [Gen a]       -- datatype of group words on a
  51.  
  52. ---- instance declarations for Gen a ------------------------------
  53.  
  54. instance Eq a => Eq (Gen a) where
  55.   P a == P a' = a == a'
  56.   N a == N a' = a == a'
  57.   _ == _      = False
  58.  
  59. instance Functor Gen where
  60.    map f (P a) = P (f a)
  61.    map f (N a) = N (f a)
  62.  
  63. ---- instance declarations for Word a ------------------------------
  64.  
  65. instance Functor Word where
  66.     map f (W xs) = W (map (map f) xs)
  67.  
  68. instance Eq a => Mult (Word a) where
  69.   unit = W ([]::[Gen a])
  70.  
  71. instance Eq a => LeftMul (Word a) (Word a) where
  72.   (W xs) * (W ys) = W (genAppend xs ys)
  73.  
  74. instance Eq [Gen a] => Eq (Word a) where
  75.   (W xs) == (W ys) = (cancel xs) == (cancel ys)
  76.  
  77. instance Text F2 where         -- how to print elements of F2
  78.   showsPrec p (W [])     = ('1':)
  79.   showsPrec p (W gs)     = ((f gs)++)
  80.            where  f []          =  ""
  81.                   f (x:xs)      = (showGen x)++(f xs)
  82.                   showGen (P g) = [g]
  83.                   showGen (N g) = g:"'"
  84.  
  85. instance Text AutF2 where      -- how to print elements of AutF2
  86.    showsPrec p f = ((effect f)++)
  87.  
  88. ------- Machinery -----------------------------
  89.  
  90. wlen :: (Word a) -> Int        -- word length
  91. wlen (W gs) = sum [ 1 | _ <- gs]
  92.  
  93. -- genCons is the key function on which composition
  94. -- of group words depends. It conses a generator, and then
  95. -- performs a cancellation, if possible.
  96. genCons :: Eq a => (Gen a) -> [Gen a] -> [Gen a]
  97. genCons x  []     = [x]
  98. genCons x (y@(x':xs)) = case (x,x') of
  99.    (P a, N a') | a == a'   -> xs
  100.                | otherwise -> x:y
  101.    (N a, P a') | a == a'   -> xs
  102.                | otherwise -> x:y
  103.    _                       -> x:y
  104.  
  105. -- genAppend is group word multiplication.
  106. genAppend :: Eq a => BinOp [Gen a]
  107. genAppend []  ys    = ys
  108. genAppend (x:xs) ys = genCons x (genAppend xs ys)
  109.  
  110. -- cancel takes a word to its reduced form.
  111. cancel :: Eq a => [Gen a] -> [Gen a]
  112. cancel []     = []
  113. cancel (g:gs) =  genCons g (cancel gs)
  114.  
  115. invert :: (Word a) -> (Word a)     -- group inverse
  116. invert (W xs) = W (reverse (map invertGen xs))
  117.  where invertGen :: (Gen a) -> (Gen a)
  118.        invertGen (P a) = N a
  119.        invertGen (N a) = P a
  120.  
  121. -- (lift f) extends f to a homomorphism, with f defined on generators.
  122. lift :: Mult (Word b) => (a->(Word b)) -> (Word a) -> (Word b)
  123. lift _ (W [])     = unit
  124. lift f (W (x:xs)) = z*(lift f (W xs) )
  125.     where z = case x of
  126.                P a -> (f a) 
  127.                N a -> invert (f a)
  128.  
  129. (^^) :: LeftMul (Word a) (Word a) => BinOp (Word a)      -- conjugation
  130. x ^^ y = (invert y)*x*y
  131.  
  132. (><) :: LeftMul (Word a) (Word a) => BinOp (Word a)      -- commutator
  133. x >< y = (invert x)*(x^^y)
  134.  
  135. {- word converts a string to a group word on Char.
  136.    The character ' inverts the previous character. 
  137.    No characters after a space are counted.-}
  138. word :: String -> F2    
  139. word ""          = unit
  140. word "'"         = unit
  141. word " "         = unit
  142. word (c:'\'':cs) = (W [N c])*(word cs)
  143. word (c:' ':_)   = (W [P c])
  144. word (c:cs)      = (W [P c])*(word cs)
  145.  
  146. x,y,x',y' :: F2    -- convenient abbreviations.
  147. x  = word "x"
  148. y  = word "y"
  149. x' = word "x'"
  150. y' = word "y'"
  151.  
  152. -- endomorphism of F2, free group on x,y, taking x,y to wx,wy.
  153. endo :: (F2, F2) -> AutF2
  154. endo (wx,wy) = lift f
  155.    where f 'x' = wx
  156.          f 'y' = wy
  157.          f _   = unit
  158.  
  159. -- display effect of an automorphism on the generators x,y.
  160. effect :: AutF2 -> String
  161. effect f = "\\x->"++(show (f x))++"\n"++"\\y->"++(show (f y))
  162.  
  163. -- reverse a list.
  164. reverse = f [] where
  165.       f ys []      = ys
  166.       f ys (x:xs)  = f (x:ys) xs
  167.  
  168. ----- End -----------------------