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

   1 import "JavaBuiltin" as Java
   2
   3 main = foldl Java.iadd (0 :: Integer) (concat (concat (Single (1 :: Integer))
   4       (Single (2 :: Integer))) (Single (3 :: Integer)))
   5
   6 data Digit a = Digit1 a
   7              | Digit2 a a
   8              | Digit3 a a a
   9              | Digit4 a a a a
  10 data Node a = Node2 a a | Node3 a a a
  11 data FingerTree a = Empty | Single a | Deep (Digit a) (FingerTree (Node a)) (Digit a)
  12
  13 insertL :: a -> FingerTree a -> FingerTree a
  14 insertL a Empty      = Single a
  15 insertL a (Single b) = Deep (Digit1 a) Empty (Digit1 b)
  16 insertL a (Deep (Digit1 b) m r) = Deep (Digit2 a b) m r
  17 insertL a (Deep (Digit2 b c) m r) = Deep (Digit3 a b c) m r
  18 insertL a (Deep (Digit3 b c d) m r) = Deep (Digit4 a b c d) m r
  19 insertL a (Deep (Digit4 b c d e) m r) = Deep (Digit2 a b) (insertL (Node3 c d e) m) r
  20
  21 insertR :: FingerTree a -> a -> FingerTree a
  22 insertR Empty a      = Single a
  23 insertR (Single a) b = Deep (Digit1 a) Empty (Digit1 b)
  24 insertR (Deep l m (Digit1 a)) b = Deep l m (Digit2 a b)
  25 insertR (Deep l m (Digit2 a b)) c = Deep l m (Digit3 a b c)
  26 insertR (Deep l m (Digit3 a b c)) d = Deep l m (Digit4 a b c d)
  27 insertR (Deep l m (Digit4 a b c d)) e = Deep l (insertR m (Node3 a b c)) (Digit2 d e)
  28
  29 foldl :: (a -> b -> a) -> a -> FingerTree b -> a
  30 foldl f init Empty = init
  31 foldl f init (Single x) = f init x
  32 foldl f init (Deep l m r) = foldlD (foldl foldlN (foldlD init l) m) r
  33   where
  34     foldlD init (Digit1 a) = f init a
  35     foldlD init (Digit2 a b) = f (f init a) b
  36     foldlD init (Digit3 a b c) = f (f (f init a) b) c
  37     foldlD init (Digit4 a b c d) = f (f (f (f init a) b) c) d
  38
  39     foldlN init (Node2 a b) = f (f init a) b
  40     foldlN init (Node3 a b c) = f (f (f init a) b) c
  41
  42 data View a = Nil | Cons a (FingerTree a)
  43
  44 viewL :: FingerTree a -> View a
  45 viewL Empty = Nil
  46 viewL (Single a) = Cons a Empty
  47 viewL (Deep (Digit1 a) m r) = Cons a tail
  48   where
  49     tail = match viewL m with
  50         Nil -> digitToFingerTree r
  51         Cons h t -> Deep (nodeToDigit h) t r
  52 viewL (Deep (Digit2 a b) m r) = Cons a (Deep (Digit1 a) m r)
  53 viewL (Deep (Digit3 a b c) m r) = Cons a (Deep (Digit2 a b) m r)
  54 viewL (Deep (Digit4 a b c d) m r) = Cons a (Deep (Digit3 a b c) m r)
  55
  56 concat :: FingerTree a -> FingerTree a -> FingerTree a
  57 concat Empty a = a
  58 concat a Empty = a
  59 concat (Single a) b = insertL a b
  60 concat a (Single b) = insertR a b
  61 concat (Deep l1 m1 r1) (Deep l2 m2 r2) = Deep l1 mm r2
  62   where
  63     mm = concatAux m1 (digitsToNodes r1 l2) m2
  64
  65 // --- Implementation details -------------------------------------------------
  66
  67 digitToFingerTree :: Digit a -> FingerTree a
  68 digitToFingerTree (Digit1 a)       = Single a
  69 digitToFingerTree (Digit2 a b)     = Deep (Digit1 a)   Empty (Digit1 b)
  70 digitToFingerTree (Digit3 a b c)   = Deep (Digit2 a b) Empty (Digit1 c)
  71 digitToFingerTree (Digit4 a b c d) = Deep (Digit2 a b) Empty (Digit2 c d)
  72
  73 nodeToDigit :: Node a -> Digit a
  74 nodeToDigit (Node2 a b)   = Digit2 a b
  75 nodeToDigit (Node3 a b c) = Digit3 a b c
  76
  77 concatAux :: FingerTree a -> Digit a -> FingerTree a -> FingerTree a
  78 concatAux Empty ds a = insertLD ds a
  79 concatAux a ds Empty = insertRD a ds
  80 concatAux (Single a) ds b = insertL a (insertLD ds b)
  81 concatAux a ds (Single b) = insertR (insertRD a ds) b
  82 concatAux (Deep l1 m1 r1) ds (Deep l2 m2 r2) = Deep l1 mm r2
  83   where
  84     mm = concatAux m1 (digitsToNodes3 r1 ds r2) m2
  85
  86 insertLD :: Digit a -> FingerTree a -> FingerTree a
  87 insertLD (Digit1 a) t = insertL a t
  88 insertLD (Digit2 a b) t = insertL a (insertL b t)
  89 insertLD (Digit3 a b c) t = insertL a (insertL b (insertL c t))
  90 insertLD (Digit4 a b c d) t = insertL a (insertL b (insertL c (insertL d t)))
  91
  92 insertRD :: FingerTree a -> Digit a -> FingerTree a
  93 insertRD t (Digit1 a) = insertR t a
  94 insertRD t (Digit2 a b) = insertR (insertR t a) b
  95 insertRD t (Digit3 a b c) = insertR (insertR (insertR t a) b) c
  96 insertRD t (Digit4 a b c d) = insertR (insertR (insertR (insertR t a) b) c) d
  97
  98 digitsToNodes :: Digit a -> Digit a -> Digit (Node a)
  99 digitsToNodes (Digit1 a) x = dd1 a x
 100 digitsToNodes (Digit2 a b) x = dd2 a b x
 101 digitsToNodes (Digit3 a b c) x = dd3 a b c x
 102 digitsToNodes (Digit4 a b c d) x = dd4 a b c d x
 103
 104 digitsToNodes3 :: Digit a -> Digit a -> Digit a -> Digit (Node a)
 105 digitsToNodes3 (Digit1 a) x y = ddd1 a x y
 106 digitsToNodes3 (Digit2 a b) x y = ddd2 a b x y
 107 digitsToNodes3 (Digit3 a b c) x y = ddd3 a b c x y
 108 digitsToNodes3 (Digit4 a b c d) x y = ddd4 a b c d x y
 109
 110 d2 a b = Digit1 (Node2 a b)
 111 d3 a b c = Digit1 (Node3 a b c)
 112 d4 a b c d = Digit2 (Node2 a b) (Node2 c d)
 113 d5 a b c d e = Digit2 (Node3 a b c) (Node2 d e)
 114 d6 a b c d e f = Digit2 (Node3 a b c) (Node3 d e f)
 115 d7 a b c d e f g = Digit3 (Node3 a b c) (Node2 d e) (Node2 f g)
 116 d8 a b c d e f g h = Digit3 (Node3 a b c) (Node3 d e f) (Node2 g h)
 117 d9 a b c d e f g h i = Digit3 (Node3 a b c) (Node3 d e f) (Node3 g h i)
 118 d10 a b c d e f g h i j = Digit4 (Node3 a b c) (Node3 d e f) (Node2 g h) (Node2 i j)
 119 d11 a b c d e f g h i j k = Digit4 (Node3 a b c) (Node3 d e f) (Node3 g h i) (Node2 j k)
 120 d12 a b c d e f g h i j k l = Digit4 (Node3 a b c) (Node3 d e f) (Node3 g h i) (Node3 j k l)
 121
 122 dd1 a (Digit1 b) = d2 a b
 123 dd1 a (Digit2 b c) = d3 a b c
 124 dd1 a (Digit3 b c d) = d4 a b c d
 125 dd1 a (Digit4 b c d e) = d5 a b c d e
 126 dd2 a b (Digit1 c) = d3 a b c
 127 dd2 a b (Digit2 c d) = d4 a b c d
 128 dd2 a b (Digit3 c d e) = d5 a b c d e
 129 dd2 a b (Digit4 c d e f) = d6 a b c d e f
 130 dd3 a b c (Digit1 d) = d4 a b c d
 131 dd3 a b c (Digit2 d e) = d5 a b c d e
 132 dd3 a b c (Digit3 d e f) = d6 a b c d e f
 133 dd3 a b c (Digit4 d e f g) = d7 a b c d e f g
 134 dd4 a b c d (Digit1 e) = d5 a b c d e
 135 dd4 a b c d (Digit2 e f) = d6 a b c d e f
 136 dd4 a b c d (Digit3 e f g) = d7 a b c d e f g
 137 dd4 a b c d (Digit4 e f g h) = d8 a b c d e f g h
 138 dd5 a b c d e (Digit1 f) = d6 a b c d e f
 139 dd5 a b c d e (Digit2 f g) = d7 a b c d e f g
 140 dd5 a b c d e (Digit3 f g h) = d8 a b c d e f g h
 141 dd5 a b c d e (Digit4 f g h i) = d9 a b c d e f g h i
 142 dd6 a b c d e f (Digit1 g) = d7 a b c d e f g
 143 dd6 a b c d e f (Digit2 g h) = d8 a b c d e f g h
 144 dd6 a b c d e f (Digit3 g h i) = d9 a b c d e f g h i
 145 dd6 a b c d e f (Digit4 g h i j) = d10 a b c d e f g h i j
 146 dd7 a b c d e f g (Digit1 h) = d8 a b c d e f g h
 147 dd7 a b c d e f g (Digit2 h i) = d9 a b c d e f g h i
 148 dd7 a b c d e f g (Digit3 h i j) = d10 a b c d e f g h i j
 149 dd7 a b c d e f g (Digit4 h i j k) = d11 a b c d e f g h i j k
 150 dd8 a b c d e f g h (Digit1 i) = d9 a b c d e f g h i
 151 dd8 a b c d e f g h (Digit2 i j) = d10 a b c d e f g h i j
 152 dd8 a b c d e f g h (Digit3 i j k) = d11 a b c d e f g h i j k
 153 dd8 a b c d e f g h (Digit4 i j k l) = d12 a b c d e f g h i j k l
 154
 155 ddd1 a (Digit1 b) y = dd2 a b y
 156 ddd1 a (Digit2 b c) y = dd3 a b c y
 157 ddd1 a (Digit3 b c d) y = dd4 a b c d y
 158 ddd1 a (Digit4 b c d e) y = dd5 a b c d e y
 159 ddd2 a b (Digit1 c) y = dd3 a b c y
 160 ddd2 a b (Digit2 c d) y = dd4 a b c d y
 161 ddd2 a b (Digit3 c d e) y = dd5 a b c d e y
 162 ddd2 a b (Digit4 c d e f) y = dd6 a b c d e f y
 163 ddd3 a b c (Digit1 d) y = dd4 a b c d y
 164 ddd3 a b c (Digit2 d e) y = dd5 a b c d e y
 165 ddd3 a b c (Digit3 d e f) y = dd6 a b c d e f y
 166 ddd3 a b c (Digit4 d e f g) y = dd7 a b c d e f g y
 167 ddd4 a b c d (Digit1 e) y = dd5 a b c d e y
 168 ddd4 a b c d (Digit2 e f) y = dd6 a b c d e f y
 169 ddd4 a b c d (Digit3 e f g) y = dd7 a b c d e f g y
 170 ddd4 a b c d (Digit4 e f g h) y = dd8 a b c d e f g h y
 171
 172 --
 173 6