Re: [Haskell-cafe] Haskell implementation of ideas from StandardML as a Metaprogramming language
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
Re: [Haskell-cafe] Haskell implementation of ideas from StandardML as a Metaprogramming language
Thank you very much Stephen ... I'll try and work on the doc plus the code
you've sent to understand it.
If you do find the parser combinators, please do send it to me.
Thanks and Regards,
Kashyap
- Original Message
From: Stephen Tetley stephen.tet...@gmail.com
Cc: haskell-cafe@haskell.org
Sent: Fri, January 15, 2010 1:08:20 AM
Subject: Re: [Haskell-cafe] Haskell implementation of ideas from StandardML
as a Metaprogramming language
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
