tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/LP.scl

   1 import "Prelude"
   2
   3 importJava "gnu.trove.map.hash.TIntFloatHashMap" where
   4     data LMap
   5
   6     @JavaName adjustOrPutValue
   7     adjustLMap_ :: LMap -> Integer -> Float -> Float -> <Proc> ()
   8
   9 @inline
  10 adjustLMap :: LMap -> Integer -> Float -> <Proc> ()
  11 adjustLMap m k v = adjustLMap_ m k v v
  12
  13 data LPTerm = LPTerm (LMap -> Float -> <Proc> ())
  14
  15 instance Additive LPTerm where
  16     @inline
  17     zero = LPTerm (\_ _ -> ())
  18     @inline
  19     LPTerm a + LPTerm b = LPTerm (\m s -> do a m s ; b m s)
  20     sum ts = LPTerm (\m s -> for ts (\(LPTerm t) -> t m s))
  21
  22 instance Ring LPTerm where
  23     @inline
  24     neg (LPTerm a) = LPTerm (\m s -> a m (-s))
  25     @inline
  26     LPTerm a - LPTerm b = LPTerm (\m s -> do a m s ; b m (-s))
  27     @inline
  28     fromInteger c = LPTerm (\m s -> adjustLMap m (-1) (fromInteger c*s))
  29     @inline
  30     one = LPTerm (\m s -> adjustLMap m (-1) s)
  31     _ * _ = fail "Multiplication is not supported."
  32
  33 data LPProblem = LPProblem (Ref Integer)
  34
  35 newProblem :: () -> <Proc> LPProblem
  36 newProblem _ = LPProblem (ref 0)
  37
  38 newVar :: LPProblem -> <Proc> LPTerm
  39 newVar (LPProblem varCounter) = do
  40     curId = getRef varCounter
  41     varCounter := curId + 1
  42     LPTerm (\m s -> adjustLMap m curId s)
  43
  44 infixl 7 (**)
  45
  46 @inline
  47 (**) :: Float -> LPTerm -> LPTerm
  48 s0 ** LPTerm t = LPTerm (\m s -> t m (s0*s))
  49
  50 /*
  51 data LPTerm = LPTerm Double (Map.T String Double)
  52
  53 instance Additive LPTerm where
  54     zero = LPTerm 0 Map.empty
  55     LPTerm c1 m1 + LPTerm c2 m2 = LPTerm (c1+c2) (Map.merge (+) m1 m2)
  56
  57 instance Ring LPTerm where
  58     one = LPTerm 1 Map.empty
  59     neg (LPTerm c m) = LPTerm (-c) (map neg m)
  60     LPTerm c1 m1 - LPTerm c2 m2 = LPTerm (c1-c2) (Map.merge (-) m1 m2)
  61
  62     LPTerm c1 [] * LPTerm c2 m2 = LPTerm (c1*c2) (Map.merge (\x -> c1*x) m2)
  63     LPTerm c1 m1 * LPTerm c2 [] = LPTerm (c1*c2) (Map.merge (\x -> c2*x) m1)
  64     _ * _ = fail "Invalid expression: not linear."
  65
  66     fromInteger i = LPTerm (fromInteger i) Map.empty
  67
  68 data LPConstraint = LPConstraint String LPTerm
  69
  70 (>==) :: LPTerm -> LPTerm -> String -> [LPConstraint]
  71 (a >== b) name = [LPConstraint name (a-b)]
  72
  73 (<==) :: LPTerm -> LPTerm -> String -> [LPConstraint]
  74 (a <== b) name = [LPConstraint name (b-a)]
  75
  76 */
  77
  78 testi () = do
  79     problem = newProblem ()
  80     a = newVar problem
  81     b = newVar problem
  82     3 ** a + 4 ** b + 15
  83
  84 main = "OK"
  85 --
  86 OK