Skip to content

Commit

Permalink
Merge pull request #800 from explorable-viz/example-fluid
Browse files Browse the repository at this point in the history
Fluid example merged
  • Loading branch information
JosephBond authored Oct 10, 2023
2 parents 8d9522f + b3ef3b3 commit e32a3c0
Show file tree
Hide file tree
Showing 17 changed files with 104 additions and 65 deletions.
11 changes: 0 additions & 11 deletions fluid/example/dtw/cost-matrix.fld

This file was deleted.

5 changes: 0 additions & 5 deletions fluid/example/dtw/cost-predicate.fld

This file was deleted.

2 changes: 0 additions & 2 deletions fluid/example/dtw/matrix-update.fld

This file was deleted.

10 changes: 0 additions & 10 deletions fluid/example/dtw/min-prev.fld

This file was deleted.

5 changes: 0 additions & 5 deletions fluid/example/dtw/next-indices.fld

This file was deleted.

5 changes: 5 additions & 0 deletions fluid/example/slicing/dtw/matrix-update.fld
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
let d x y = (x - y) * (x - y);
let seq1 = [3,1,2,2,1];
seq2 = [2,0,0,3,3,1,0];
window = 2
in computeDTW seq1 seq2 d window
45 changes: 45 additions & 0 deletions fluid/lib/dtw.fld
Original file line number Diff line number Diff line change
@@ -0,0 +1,45 @@
let nextIndices n m window =
[(i, j) | i <- [1 .. n],
j <- [(max 1 (i - window)) .. (min m (i + window))]];

let costMatrixInit rows cols window =
[| let initV = if or (and (n == 1) (m == 1)) (and (abs n m <= window) (not (or (n == 1) (m == 1))))
then FNum 0
else Infty
in initV | (n, m) in (rows, cols) |];

let minAndPrev (i, j) im1 jm1 ijm1 =
let minim = minimal [im1, jm1, ijm1] in
if eq minim im1 then
((i, j + 1), minim)
else
if eq minim jm1 then
((i + 1, j ), minim)
else ((i, j), minim);
let extractPath indmatrix (i, j) =
let traverser (n,m) matrix accum =
if and (n == 1) (m == 1)
then accum
else
traverser (matrix!(n,m)) matrix ((n - 1,m - 1) : accum)
in traverser (i,j) indmatrix Nil;
let localMinUpdate seq1 seq2 cost (costmatrix, indmatrix) (i, j) =
let iEntr = nth (i - 1) seq1;
jEntr = nth (j - 1) seq2;
dist = cost iEntr jEntr;
im1 = costmatrix!(i , j + 1);
jm1 = costmatrix!(i + 1, j);
im1jm1 = costmatrix!(i , j);
(prev, minim) = minAndPrev (i, j) im1 jm1 im1jm1;
newVal = add (FNum dist) minim
in (matrixUpdate costmatrix (i + 1,j + 1) newVal, matrixUpdate indmatrix (i + 1,j + 1) prev);

let computeDTW seq1 seq2 cost window =
let n = length seq1;
m = length seq2;
initD = costMatrixInit (n + 1) (m + 1) window;
initI = [| 0 | (i,j) in (n + 1, m + 1)|];
indexing = nextIndices n m window;
(finished, indices) = foldl (localMinUpdate seq1 seq2 cost) (initD, initI) indexing
in
(finished, extractPath indices (n + 1,m + 1));
23 changes: 23 additions & 0 deletions fluid/lib/fnum.fld
Original file line number Diff line number Diff line change
@@ -0,0 +1,23 @@
let comp Infty Infty = EQ;
comp Infty (FNum y) = GT;
comp (FNum x) Infty = LT;
comp (FNum x) (FNum y) = compare x y;

let fmin x y =
match comp x y as {
LT -> x;
EQ -> x;
GT -> y
};

let minimal = foldl1 fmin;

let add Infty (FNum x) = Infty;
add (FNum x) Infty = Infty;
add (FNum x) (FNum y) = FNum (x + y);
add Infty Infty = Infty;

let eq Infty Infty = True;
eq Infty (FNum x) = False;
eq (FNum x) Infty = False;
eq (FNum x) (FNum y) = x == y;
3 changes: 3 additions & 0 deletions fluid/lib/prelude.fld
Original file line number Diff line number Diff line change
Expand Up @@ -226,3 +226,6 @@ let enumFromTo n m =

let range (m1, n1) (m2, n2) =
[ (i1, i2) | i1 <- [m1 .. m2], i2 <- [n1 .. n2] ];

-- Int -> Int -> Int (should probably be defined differently but this works for now)
let abs x y = if x - y < 0 then negate (x - y) else (x - y);
3 changes: 1 addition & 2 deletions package-lock.json

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 1 addition & 1 deletion package.json
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,6 @@
"purescript-psa": "0.8.2",
"purs-backend-es": "1.1.0",
"purs-tidy": "^0.9.3",
"spago": "0.20.9"
"spago": "^0.20.9"
}
}
2 changes: 2 additions & 0 deletions src/Module.purs
Original file line number Diff line number Diff line change
Expand Up @@ -69,6 +69,8 @@ defaultImports =
>>= module_ (File "prelude")
>>= module_ (File "graphics")
>>= module_ (File "convolution")
>>= module_ (File "fnum")
>>= module_ (File "dtw")

datasetAs :: forall m. MonadAff m => MonadError Error m => File -> Var -> Raw ProgCxt -> m (Raw ProgCxt)
datasetAs file x (ProgCxt r@{ datasets }) = do
Expand Down
16 changes: 8 additions & 8 deletions src/Primitive/Defs.purs
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,7 @@ import Data.Int (quot, rem) as I
import Data.List (List(..), (:))
import Data.Number (log, pow) as N
import Data.Profunctor.Strong (first, second)
import Data.Set (singleton, insert)
import Data.Set (empty, insert, singleton)
import Data.Traversable (for, sequence, traverse)
import Data.Tuple (fst, snd)
import DataType (cCons, cPair)
Expand All @@ -21,7 +21,7 @@ import Eval (apply, apply2)
import EvalBwd (apply2Bwd, applyBwd)
import EvalGraph (apply) as G
import Graph.GraphWriter (new)
import Lattice (class BoundedJoinSemilattice, Raw, (∨), (∧), bot, botOf, erase)
import Lattice (class BoundedJoinSemilattice, Raw, bot, botOf, erase, top, (∧), (∨))
import Partial.Unsafe (unsafePartial)
import Prelude (div, mod) as P
import Primitive (binary, binaryZero, boolean, int, intOrNumber, intOrNumberOrString, number, string, unary, union, union1, unionStr)
Expand Down Expand Up @@ -141,27 +141,27 @@ matrixMut :: ForeignOp
matrixMut = mkExists $ ForeignOp' { arity: 3, op': op, op: fwd, op_bwd: bwd }
where
op :: OpGraph
op (Matrix α r : Constr _ c (Int _ i : Int _ j : Nil) : v : Nil)
| c == cPair = Matrix <$> new (singleton α) <@> (matrixUpdate i j (const v) r)
op (Matrix _ r : Constr _ c (Int _ i : Int _ j : Nil) : v : Nil)
| c == cPair = Matrix <$> new empty <@> (matrixUpdate i j (const v) r)
op _ = throw "Matrix, pair of ints, and new val expected"

fwd :: OpFwd (Raw MatrixRep × (Int × Int) × Raw Val)
fwd (Matrix α r@(MatrixRep (vss × (i' × _) × (j' × _))) : Constr _ c (Int _ i : Int _ j : Nil) : v : Nil)
fwd (Matrix _ r@(MatrixRep (vss × (i' × _) × (j' × _))) : Constr _ c (Int _ i : Int _ j : Nil) : v : Nil)
| c == cPair =
let
oldV = matrixGet i j r
newM = matrixUpdate i j (const v) r
in
pure $ (MatrixRep ((map erase <$> vss) × ((i' × unit) × (j' × unit))) × (i × j) × (erase oldV)) × (Matrix α newM)
pure $ (MatrixRep ((map erase <$> vss) × ((i' × unit) × (j' × unit))) × (i × j) × (erase oldV)) × (Matrix top newM)

fwd _ = throw "Matrix, pair of ints, and new val expected"

bwd :: OpBwd (Raw MatrixRep × (Int × Int) × Raw Val)
bwd ((((MatrixRep (vss × (i' × _) × (j' × _))) × (i × j) × oldV) × (Matrix α r))) =
bwd ((((MatrixRep (vss × (i' × _) × (j' × _))) × (i × j) × oldV) × (Matrix _ r))) =
let
newV = matrixGet i j r
in
Matrix α (matrixUpdate i j (const (map (const bot) oldV)) (MatrixRep (((<$>) botOf <$> vss) × (i' × bot) × (j' × bot))))
Matrix bot (matrixUpdate i j (const (map (const bot) oldV)) (MatrixRep (((<$>) botOf <$> vss) × (i' × bot) × (j' × bot))))
: Constr bot cPair (Int bot i : Int bot j : Nil)
: newV
: Nil
Expand Down
13 changes: 7 additions & 6 deletions test/Main.purs
Original file line number Diff line number Diff line change
Expand Up @@ -27,13 +27,14 @@ tests = concat

test_scratchpad :: Array (String × Aff Unit)
test_scratchpad = second void <$> many
[ { file: "dtw/matrix-update"
[ { file: "slicing/dtw/matrix-update"
, fwd_expect:
"FNum 0, Infty, Infty, Infty, Infty, Infty, Infty,\n\
\Infty, FNum 0, FNum 0, Infty, Infty, Infty, Infty,\n\
\Infty, FNum 0, FNum 0, FNum 0, Infty, Infty, Infty,\n\
\Infty, Infty, FNum 0, FNum 0, FNum 0, Infty, Infty,\n\
\Infty, Infty, Infty, FNum 0, FNum 0, FNum 0, Infty"
"(FNum 0, Infty, Infty, Infty, Infty, Infty, Infty, Infty,\n\
\ Infty, FNum 1, FNum 10, FNum 19, Infty, Infty, Infty, Infty,\n\
\ Infty, FNum 2, FNum 2, FNum 3, FNum 7, Infty, Infty, Infty,\n\
\ Infty, FNum 2, FNum 6, FNum 6, FNum 4, FNum 5, Infty, Infty,\n\
\ Infty, Infty, FNum 6, FNum 10, FNum 5, FNum 5, FNum 6, Infty,\n\
\ Infty, Infty, Infty, FNum 7, FNum 9, FNum 9, FNum 5, FNum 6, ((1, 1) : ((2, 2) : ((2, 3) : ((3, 4) : ((4, 5) : ((5, 6) : ((5, 7) : []))))))))"
}
]
(1 × false)
Expand Down
20 changes: 7 additions & 13 deletions test/Spec/Specs.purs
Original file line number Diff line number Diff line change
Expand Up @@ -40,20 +40,14 @@ misc_cases =
, { file: "range", fwd_expect: "((0, 0) : ((0, 1) : ((1, 0) : ((1, 1) : []))))" }
, { file: "records", fwd_expect: "{a : 2, b : 6, c : 7, d : (5 : []), e : 7}" }
, { file: "reverse", fwd_expect: "(2 : (1 : []))" }
, { file: "dtw/next-indices", fwd_expect: "((1, 1) : ((1, 2) : ((1, 3) : ((2, 1) : ((2, 2) : ((2, 3) : ((2, 4) : ((3, 1) : ((3, 2) : ((3, 3) : ((3, 4) : ((3, 5) : ((4, 2) : ((4, 3) : ((4, 4) : ((4, 5) : ((4, 6) : ((5, 3) : ((5, 4) : ((5, 5) : ((5, 6) : ((5, 7) : []))))))))))))))))))))))" }
, { file: "dtw/cost-matrix"
, { file: "slicing/dtw/matrix-update"
, fwd_expect:
"FNum 0, Infty, Infty, Infty, Infty, Infty, Infty,\n\
\Infty, FNum 0, FNum 0, Infty, Infty, Infty, Infty,\n\
\Infty, FNum 0, FNum 0, FNum 0, Infty, Infty, Infty,\n\
\Infty, Infty, FNum 0, FNum 0, FNum 0, Infty, Infty,\n\
\Infty, Infty, Infty, FNum 0, FNum 0, FNum 0, Infty"
}
, { file: "dtw/matrix-update"
, fwd_expect:
"100, (1, 2), (1, 3),\n\
\(2, 1), (2, 2), (2, 3),\n\
\(3, 1), (3, 2), (3, 3)"
"(FNum 0, Infty, Infty, Infty, Infty, Infty, Infty, Infty,\n\
\ Infty, FNum 1, FNum 10, FNum 19, Infty, Infty, Infty, Infty,\n\
\ Infty, FNum 2, FNum 2, FNum 3, FNum 7, Infty, Infty, Infty,\n\
\ Infty, FNum 2, FNum 6, FNum 6, FNum 4, FNum 5, Infty, Infty,\n\
\ Infty, Infty, FNum 6, FNum 10, FNum 5, FNum 5, FNum 6, Infty,\n\
\ Infty, Infty, Infty, FNum 7, FNum 9, FNum 9, FNum 5, FNum 6, ((1, 1) : ((2, 2) : ((2, 3) : ((3, 4) : ((4, 5) : ((5, 6) : ((5, 7) : []))))))))"
}
]

Expand Down
2 changes: 1 addition & 1 deletion test/Util.purs
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,7 @@ type TestConfig =
type AffError m a = MonadAff m => MonadError Error m => m a

logging :: Boolean
logging = false
logging = true

test forall m. File -> ProgCxt Unit -> TestConfig -> (Int × Boolean) -> AffError m BenchRow
test file progCxt tconfig (n × is_bench) = do
Expand Down
2 changes: 1 addition & 1 deletion yarn.lock
Original file line number Diff line number Diff line change
Expand Up @@ -2529,7 +2529,7 @@ source-map@^0.6.1:
resolved "https://registry.npmjs.org/source-map/-/source-map-0.6.1.tgz"
integrity sha512-UjgapumWlbMhkBgzT7Ykc5YXUT46F0iKu8SGXq0bcwP5dz/h0Plj6enJqjz1Zbq2l5WaqYnrVbwWOWMyF3F47g==

[email protected]:
spago@^0.20.9:
version "0.20.9"
resolved "https://registry.npmjs.org/spago/-/spago-0.20.9.tgz"
integrity sha512-r5TUxnYn9HawlQyMswlhIk24BGFSN2KGbqgZFZrn47GjTpMscU14xkt9CqTWgoSQYsoZieG+3dUtOxUQ7GYD7w==
Expand Down

0 comments on commit e32a3c0

Please sign in to comment.