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

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