[Haskell-cafe] Haskell implementation of ideas from StandardML as a Metaprogramming language

[Stephen Tetley]

Hello Kashyap

I can do MSL and Region, maybe I did the parser combinators but I
can't find them at the moment.

I tried to keep the code close to the original SML, so as Haskell code
its not pretty. Not having quasiquote was a problem.

Best wishes

Stephen


--------------------------------------------------------------------------------
-- MSL


module MSL where


type Expr = String
type Predicate = Expr
type Statement = String
type Fieldname = String

data Bitsource = Source Expr Expr
  deriving Show


newbitsource a i  = Source a i

initbs (Source _ i) =  i ++ " = 0;"

getByte (Source a i)  =  a ++ "[" ++  i ++ "/8]"

getNthByte :: Bitsource -> Int -> Expr
getNthByte (Source a i) n
    | n == 0    = a ++ "[" ++  i ++ "/8]"
    | otherwise = a ++ "[" ++  i ++ "/8+" ++ show n ++ "]"

advanceByte (Source a i) = i ++ " = " ++ i ++ "-(" ++ i ++ "%8)+8;"

advanceNBytes (Source a i) n
    | n == 0    = ""
    | otherwise = i ++ " = " ++ i ++ "-(" ++ i ++ "%8)+(8*" ++ show n++");"


data Recordfield = Field Expr [Fieldname]
  deriving Show

recordptr :: Expr -> Recordfield
recordptr e  = Field e []

subfield :: Recordfield -> Fieldname -> Recordfield
subfield (Field e fl) f  = Field e (f:fl)

deref :: Recordfield -> Expr
deref (Field e fl)
    = "(*" ++e++ ")" ++ concat ( map cojoin (reverse fl) )
  where
    cojoin :: Fieldname -> String
    cojoin s = "." ++ s	



type Message = Bitsource -> Recordfield -> Statement -> Statement	

infield :: Fieldname -> Message -> Message
infield f m src tgt
    = m src (subfield tgt f)


c_if :: Expr -> Statement -> Statement -> Statement
c_if e s1 s2
    = if e=="1" || e=="(1)"
         then s1
         else "if("++e++"){"
                        ++ s1
                        ++ "}" ++ if s2 /= "" then "else {" ++ s2 ++ "}" else ""


seqmsg :: [Message] -> Message
seqmsg (m:ml) src tgt s
      = (m src tgt "error_action();") ++  (seqmsg ml src tgt s)
seqmsg [] _ _ _ = ""

asc2Int :: Int -> (Int,Int) -> Message
asc2Int w (lo,hi) src tgt s
     = c_if ("inrange(" ++ (getByte src) ++ ", "
                        ++ (ms w) ++ ", " ++ (ms lo)
                        ++ ", " ++ (ms hi))
                        ""
                        s
  where
      ms n = show n	


alt :: [Message] -> Message
alt (m:ml) src tgt s
      = m src tgt (alt ml src tgt s)


delim :: Expr -> Message
delim e src tgt s
      = "if (" ++ getByte src ++ " == " ++ e ++")"
               ++ advanceByte src

rangex :: Int -> Int -> [Int]
rangex i j
        | i > j     = []
        | otherwise = (i:(rangex (i+1) j))


c_and [] =  ""
c_and [pred] = "(" ++ pred ++ ")"	
c_and (pred1:pred2:preds) = "(" ++ pred1 ++ " && " ++ c_and (pred2:preds) ++ ")"

asc :: String -> String -> Message
asc chars value src tgt s
      = c_if ""
             (deref tgt ++ " == " ++ value ++ ";" )
             s

skip :: Int -> Message
skip n src tgt s
      = (deref tgt) ++ "= 1;"
                    ++ (advanceNBytes src n)

--------------------------------------------------------------------------------

bs = newbitsource "A" "bit"
f = recordptr "target"


main = delim "6" bs f "abort();"


to_confidence = alt [ asc "HH" "High"
                    , asc "MM" "Medium"
                    , asc "LL" "Low"
                    , asc "NN" "None"
                    ]	


--------------------------------------------------------------------------------
-- Region

-- This one doesn't work properly -
-- CPoints are difficult to manipulate as strings, hence the `hasVar`
-- problems, it gives some idea of the method though.



module Region where

import Data.Char ( isAlpha )
import Data.List ( foldl' )


-- Prolog
type CExpr = String
type CPred = String
type CFloat = Float

infixr 6 ++&
(++&) :: Show a => String -> a -> String
s ++& a = s ++ show a


sqrdist _ = ""

add :: CPoint -> CPoint -> CPoint
add a b = a ++ "+" ++ b

sub :: CPoint -> CPoint -> CPoint
sub a b = a ++ "-" ++ b

hasVar :: CExpr -> Bool
hasVar = any isAlpha

cfst :: CPoint -> CExpr
cfst a | hasVar a   = a ++ ".x"
       | otherwise  = "1.1"

csnd :: CPoint -> CExpr
csnd a | hasVar a   = a ++".y"
       | otherwise  = "2.2"

pt :: (CFloat,CFloat) -> CPoint
pt = show

intersect :: [Region] -> Region
intersect (r:rs) = foldl' (/\) r rs
intersect []     = error $ "intersect on empty list"



-- presentation

type CPoint = CExpr
type Region = CPoint -> CPred


circle :: CFloat -> Region
circle n = \p -> "(" ++ sqrdist p ++ "<" ++& n ++ "*" ++& n ++ ")"

halfplane :: CPoint -> CPoint -> Region
halfplane a b = \p -> "(" ++ zcross (a `sub` p) (b `sub` a) ++ " > 0.0)"
  where
    zcross e1 e2 =
      "(" ++ cfst e1 ++ "*" ++ csnd e2 ++ "-" ++ csnd e2 ++ "*" ++
cfst e1 ++ ")"


(/\) :: Region -> Region -> Region
r1 /\ r2 = \p -> "(" ++ r1 p ++ " && " ++ r2 p ++ ")"

(\/) :: Region -> Region -> Region
r1 \/ r2 = \p -> "(" ++ r1 p ++ " || " ++ r2 p ++ ")"

at :: Region -> CPoint -> Region
r `at` p0 = \p -> r (p `sub` p0)

convexPoly :: [CPoint] -> Region
convexPoly (p:ps) =
  intersect (zipWith halfplane ([p] ++ ps) (ps ++ [p]))


tightZone :: CPoint -> CPred
tightZone =
  (convexPoly [pt (0.0,5.0), pt (118.0,32.0),
               pt (118.0,62.0), pt (0.0,25.0) ])
    \/
  (convexPoly [pt (118.0,32.0), pt (259.0,5.0),
               pt (259.0, 25.0), pt (118.0,62.0)])


main = tightZone e1 where
    e1::CExpr
    e1 = "p"