I'm implementing the LLL basis reduction algorithm in Haskell. I'm basing my code on the pseudocode on Wikipedia. Here is what I have so far. Apologies for the code dump; I strongly suspect the issue lies in lll but I'm giving everything just in case.
import Linear as L
f v x = v `L.dot` x
gram_schmidt b =
let aux vs us =
case vs of
v:t -> let vus = map (\u -> project u v) us
s = foldr (^+^) zero vus
u = v ^-^ s in
aux t (us++[u])
[] -> us
in aux b []
swap :: Int -> Int -> [a] -> [a]
swap i j xs =
let elemI = xs !! i
elemJ = xs !! j
left = take i xs
middle = take (j - i - 1) (drop (i + 1) xs)
right = drop (j + 1) xs
in left ++ [elemJ] ++ middle ++ [elemI] ++ right
update i xs new =
let left = take (i-1) xs
right = drop (i) xs
in left ++ [new] ++ right
sort_vecs vs = map snd (sort (zip (map norm vs) vs))
lll :: Int -> [[Double]] -> Double -> [[Double]]
lll d b delta =
let b' = gram_schmidt b
aux :: [[Double]] -> [[Double]] -> Int -> [[Double]]
aux b b' k =
if k >= d then
b
else
let aux2 :: [[Double]] -> [[Double]] -> Int -> [[Double]]
aux2 b b' j =
if j < 0 then
let mu = (f (b!!k) (b'!!(k-1))) / (f (b'!!(k-1)) (b'!!(k-1))) in
if f (b'!!k) (b'!!k) >= (delta-mu^2) * f (b'!!(k-1)) (b'!!(k-1)) then
aux b b' (k+1)
else
let bb = swap k (k-1) b
bb' = gram_schmidt bb in
aux bb bb' (max (k-1) 1)
else
let mu = (f (b!!k) (b'!!j)) / (f (b'!!j) (b'!!j)) in
if abs mu > 0.5 then
let bk = b!!k
bj = b!!j
bb = update k b (bk ^-^ (fromIntegral (round mu)) *^ bj)
bb' = gram_schmidt bb in
aux2 bb bb' (j-1)
else
aux2 b b' (j-1)
in aux2 b b' (k-1)
in sort_vecs (aux b b' 1)
My issue is that it seems to find a basis of a sublattice. In particular, lll d [[-0.8526334764831849,-3.125000000000004e-2],[-1.2941941738241598,4.419417382415916e-2]] 0.75 returns [[0.41107277914220997,0.10669417382415924],[-1.2941941738241598,4.419417382415916e-2]], a basis for a index-2 sublattice, and with basis which are almost-parallel. I've been staring at this code for ages to no avail (I thought there was an issue with update where (i-1) should be (i) and (i) should be (i+1) but this caused an infinite loop). Any help is greatly appreciated.
As a followup to this, I realized I need to use a heterogeneous composition to make a lid for a partial box. Here I have removed all the unnecessary cruft:
{-# OPTIONS --cubical #-}
module _ where
open import Cubical.Core.Everything
open import Cubical.Foundations.Everything
postulate
A : Type
P : A → Type
PIsProp : ∀ x → isProp (P x)
prove : ∀ x → P x
x y : A
q : x ≡ y
a = prove x
b = prove y
prf : PathP (λ i → P (q i)) a b
prf = p
where
b′ : P y
b′ = subst P q a
r : PathP _ a b′
r = transport-filler (λ i → P (q i)) a
-- a b
-- ^ ^
-- | |
-- refl | | PIsProp y _ _
-- | |
--- a ---------> b′
-- r
p-faces : (i j : I) → Partial (i ∨ ~ i) (P (q i))
p-faces i j (i = i0) = a
p-faces i j (i = i1) = PIsProp y b′ b j
p : PathP (λ i → P (q i)) a b
p i = comp (λ j → P (q i)) ? (r i)
So here the only remaining hole is in the defintion of p. I'd like to fill it with p-faces i, of course, because that is the reason I defined it. However, this leads to a universe level error:
p : PathP (λ i → P (q i)) a b
p i = comp (λ j → P (q i)) (p-faces i) (r i)
Agda.Primitive.SSet ℓ-zero != Agda.Primitive.SSetω
when checking that the expression p-faces i has type
(i₁ : I) → Partial (i ∨ ~ i) (P (q i))
However, if I inline the definition of p-faces into p, it typechecks; note that this also includes typechecking the definition of p-faces (I don't need to remove it), it is only the usage of p-faces that causes this type error:
p : PathP (λ i → P (q i)) a b
p i = comp (λ j → P (q i)) (λ { j (i = i0) → a; j (i = i1) → PIsProp y b′ b j }) (r i)
What is the issue with using p-faces in the definition of p? To my untrained eyes, it looks like a normal definition never going above Type₀
I see you are using agda/master!
The following would have also worked
p i = comp (λ j → P (q i)) (\ j -> p-faces i j) (r i)
with the introduction of --two-level the types of comp and transp trigger a problem with sort assignment for universe polymorphism, so some eta expansion is needed here to let Agda check the lambda at the sort it wants.
Hopefully we'll find a better solution soon.
I have the following code running in ST using random numbers:
module Main
import Data.Vect
import Data.Fin
import Control.ST
import Control.ST.Random
%default total
choose : (Monad m) => (rnd : Var) -> (n : Nat) -> Vect (n + k) a -> ST m (Vect n a, Vect k a) [rnd ::: Random]
choose rnd n xs = pure $ splitAt n xs -- Dummy implementation
partitionLen : (a -> Bool) -> Vect n a -> DPair (Nat, Nat) (\(m, k) => (m + k = n, Vect m a, Vect k a))
partitionLen p [] = ((0, 0) ** (Refl, [], []))
partitionLen p (x :: xs) = case partitionLen p xs of
((m, k) ** (prf, lefts, rights)) =>
if p x then
((S m, k) ** (cong prf, x::lefts, rights))
else
((m, S k) ** (trans (plusS m k) (cong prf), lefts, x::rights))
where
plusS : (x : Nat) -> (y : Nat) -> x + (S y) = S (x + y)
plusS Z y = Refl
plusS (S x) y = cong (plusS x y)
generate : (Monad m) => (rnd : Var) -> ST m (Vect 25 (Fin 25)) [rnd ::: Random]
generate rnd = do
(shared, nonshared) <- choose rnd 4 indices
(agents1, nonagents1) <- choose rnd 6 nonshared
(agents2, nonagents2) <- choose rnd 6 nonagents1
(assassins1, others1) <- choose rnd 2 nonagents1
case partitionLen (`elem` assassins1) nonagents2 of
((n, k) ** (prf, xs, ys)) => do
(assassins2, others2') <- choose rnd 2 (agents1 ++ xs)
let prf' = trans (sym $ plusAssociative 4 n k) $ cong {f = (+) 4} prf
let others2 = the (Vect 13 (Fin 25)) $ replace {P = \n => Vect n (Fin 25)} prf' (others2' ++ ys)
pure $ shared ++ agents2 ++ assassins2 ++ others2
where
indices : Vect 25 (Fin 25)
indices = fromList [0..24]
I'd like to refactor generate so that instead of the whole tail of the computation is under a case, I would compute (assassins2, others2) in a sub-computation, i.e. I would like to rewrite it as such:
(assassins2, others2) <- case partitionLen (`elem` assassins1) nonagents2 of
((n, k) ** (prf, xs, ys)) => do
(assassins2, others2') <- choose rnd 2 (agents1 ++ xs)
let prf' = trans (sym $ plusAssociative 4 n k) $ cong {f = (+) 4} prf
let others2 = replace {P = \n => Vect n (Fin 25)} prf' (others2' ++ ys)
pure (assassins2, others2)
pure $ shared ++ agents2 ++ assassins2 ++ others2
I believe this should be an equivalent transformation. However, this second version fails type-checking with:
When checking right hand side of Main.case block in case block in case block in case block in case block in generate with expected type
STrans m
(Vect 25 (Fin 25))
(st2_fn (assassins2, others2))
(\result => [rnd ::: State Integer])
When checking argument ys to function Data.Vect.++:
Type mismatch between
B (Type of others2)
and
Vect n (Fin 25) (Expected type)
I've written a simple implementation of Conway's Game of Life using the Store comonad (see code below). My problem is that the grid generation is getting visibly slower from the fifth iteration onwards. Is my issue related to the fact that I'm using the Store comonad? Or am I making a glaring mistake? As far as I could tell, other implementations, which are based on the Zipper comonad, are efficient.
import Control.Comonad
data Store s a = Store (s -> a) s
instance Functor (Store s) where
fmap f (Store g s) = Store (f . g) s
instance Comonad (Store s) where
extract (Store f a) = f a
duplicate (Store f s) = Store (Store f) s
type Pos = (Int, Int)
seed :: Store Pos Bool
seed = Store g (0, 0)
where
g ( 0, 1) = True
g ( 1, 0) = True
g (-1, -1) = True
g (-1, 0) = True
g (-1, 1) = True
g _ = False
neighbours8 :: [Pos]
neighbours8 = [(x, y) | x <- [-1..1], y <- [-1..1], (x, y) /= (0, 0)]
move :: Store Pos a -> Pos -> Store Pos a
move (Store f (x, y)) (dx, dy) = Store f (x + dx, y + dy)
count :: [Bool] -> Int
count = length . filter id
getNrAliveNeighs :: Store Pos Bool -> Int
getNrAliveNeighs s = count $ fmap (extract . move s) neighbours8
rule :: Store Pos Bool -> Bool
rule s = let n = getNrAliveNeighs s
in case (extract s) of
True -> 2 <= n && n <= 3
False -> n == 3
blockToStr :: [[Bool]] -> String
blockToStr = unlines . fmap (fmap f)
where
f True = '*'
f False = '.'
getBlock :: Int -> Store Pos a -> [[a]]
getBlock n store#(Store _ (x, y)) =
[[extract (move store (dx, dy)) | dy <- yrange] | dx <- xrange]
where
yrange = [(x - n)..(y + n)]
xrange = reverse yrange
example :: IO ()
example = putStrLn
$ unlines
$ take 7
$ fmap (blockToStr . getBlock 5)
$ iterate (extend rule) seed
The store comonad per se doesn't really store anything (except in an abstract sense that a function is a “container”), but has to compute it from scratch. That clearly gets very inefficient over a couple of iterations.
You can alleviate this with no change to your code though, if you just back up the s -> a function with some memoisation:
import Data.MemoTrie
instance HasTrie s => Functor (Store s) where
fmap f (Store g s) = Store (memo $ f . g) s
instance HasTrie s => Comonad (Store s) where
extract (Store f a) = f a
duplicate (Store f s) = Store (Store f) s
Haven't tested whether this really gives acceptable performance.
Incidentally, Edward Kmett had an explicitly-memoised version in an old version of the comonad-extras package, but it's gone now. I've recently looked if that still works (seems like it does, after adjusting dependencies).
This is my very first F# programme. I thought I would implement Conway's Game of Life as a first exercise.
Please help me understand why the following code has such terrible performance.
let GetNeighbours (p : int, w : int, h : int) : seq<int> =
let (f1, f2, f3, f4) = (p > w, p % w <> 1, p % w <> 0, p < w * (h - 1))
[
(p - w - 1, f1 && f2);
(p - w, f1);
(p - w + 1, f1 && f3);
(p - 1, f2);
(p + 1, f3);
(p + w - 1, f4 && f2);
(p + w, f4);
(p + w + 1, f4 && f3)
]
|> List.filter (fun (s, t) -> t)
|> List.map (fun (s, t) -> s)
|> Seq.cast
let rec Evolve (B : seq<int>, S : seq<int>, CC : seq<int>, g : int) : unit =
let w = 10
let h = 10
let OutputStr = (sprintf "Generation %d: %A" g CC) // LINE_MARKER_1
printfn "%s" OutputStr
let CCN = CC |> Seq.map (fun s -> (s, GetNeighbours (s, w, h)))
let Survivors =
CCN
|> Seq.map (fun (s, t) -> (s, t |> Seq.map (fun u -> (CC |> Seq.exists (fun v -> u = v)))))
|> Seq.map (fun (s, t) -> (s, t |> Seq.filter (fun u -> u)))
|> Seq.map (fun (s, t) -> (s, Seq.length t))
|> Seq.filter (fun (s, t) -> (S |> Seq.exists (fun u -> t = u)))
|> Seq.map (fun (s, t) -> s)
let NewBorns =
CCN
|> Seq.map (fun (s, t) -> t)
|> Seq.concat
|> Seq.filter (fun s -> not (CC |> Seq.exists (fun t -> t = s)))
|> Seq.groupBy (fun s -> s)
|> Seq.map (fun (s, t) -> (s, Seq.length t))
|> Seq.filter (fun (s, t) -> B |> Seq.exists (fun u -> u = t))
|> Seq.map (fun (s, t) -> s)
let NC = Seq.append Survivors NewBorns
let SWt = new System.Threading.SpinWait ()
SWt.SpinOnce ()
if System.Console.KeyAvailable then
match (System.Console.ReadKey ()).Key with
| System.ConsoleKey.Q -> ()
| _ -> Evolve (B, S, NC, (g + 1))
else
Evolve (B, S, NC, (g + 1))
let B = [3]
let S = [2; 3]
let IC = [4; 13; 14]
let g = 0
Evolve (B, S, IC, g)
The first five iterations, i.e. generations 0, 1, 2, 3, 4, happen without a problem. Then, after a brief pause of about 100 milliseconds, generation 5 is completed. But after that, the programme hangs at the line marked "LINE_MARKER_1," as revealed by breakpoints Visual Studio. It never reaches the printfn line.
The strange thing is, already by generation 2, the CC sequence in the function Evolve has already stabilised to the sequence [4; 13; 14; 3] so I see no reason why generation 6 should fail to evolve.
I understand that it is generally considered opprobrious to paste large segments of code and ask for help in debugging, but I don't know how to reduce this to a minimum working example. Any pointers that would help me debug would be gratefully acknowledged.
Thanks in advance for your help.
EDIT
I really believe that anyone wishing to help me may pretty much ignore the GetNeighbours function. I included it only for the sake of completeness.
The simplest way to fix your performance is by using Seq.cache:
let GetNeighbours (p : int, w : int, h : int) : seq<int> =
let (f1, f2, f3, f4) = (p > w, p % w <> 1, p % w <> 0, p < w * (h - 1))
[
(p - w - 1, f1 && f2);
(p - w, f1);
(p - w + 1, f1 && f3);
(p - 1, f2);
(p + 1, f3);
(p + w - 1, f4 && f2);
(p + w, f4);
(p + w + 1, f4 && f3)
]
|> List.filter (fun (s, t) -> t)
|> List.map (fun (s, t) -> s)
:> seq<_> // <<<<<<<<<<<<<<<<<<<<<<<< MINOR EDIT, avoid boxing
let rec Evolve (B : seq<int>, S : seq<int>, CC : seq<int>, g : int) : unit =
let w = 10
let h = 10
let OutputStr = (sprintf "Generation %d: %A" g CC) // LINE_MARKER_1
printfn "%s" OutputStr
let CCN =
CC
|> Seq.map (fun s -> (s, GetNeighbours (s, w, h)))
|> Seq.cache // <<<<<<<<<<<<<<<<<< EDIT
let Survivors =
CCN
|> Seq.map (fun (s, t) -> (s, t |> Seq.map (fun u -> (CC |> Seq.exists (fun v -> u = v)))))
|> Seq.map (fun (s, t) -> (s, t |> Seq.filter (fun u -> u)))
|> Seq.map (fun (s, t) -> (s, Seq.length t))
|> Seq.filter (fun (s, t) -> (S |> Seq.exists (fun u -> t = u)))
|> Seq.map (fun (s, t) -> s)
let NewBorns =
CCN
|> Seq.map (fun (s, t) -> t)
|> Seq.concat
|> Seq.filter (fun s -> not (CC |> Seq.exists (fun t -> t = s)))
|> Seq.groupBy (fun s -> s)
|> Seq.map (fun (s, t) -> (s, Seq.length t))
|> Seq.filter (fun (s, t) -> B |> Seq.exists (fun u -> u = t))
|> Seq.map (fun (s, t) -> s)
let NC =
Seq.append Survivors NewBorns
|> Seq.cache // <<<<<<<<<<<<<<<<<< EDIT
let SWt = new System.Threading.SpinWait ()
SWt.SpinOnce ()
if System.Console.KeyAvailable then
match (System.Console.ReadKey ()).Key with
| System.ConsoleKey.Q -> ()
| _ -> Evolve (B, S, NC, (g + 1))
else
Evolve (B, S, NC, (g + 1))
let B = [3]
let S = [2; 3]
let IC = [4; 13; 14]
let g = 0
Evolve (B, S, IC, g)
The big problem is not using Seq per se, the problem is using it correctly. By default sequences are not lazy, instead they define computations that are re-evaluated on every traversal. This means that unless you do something about it (such as Seq.cache), re-evaluating the sequence may screw up the algorithmic complexity of your program.
Your original program has exponential complexity. To see that, note that it doubles the number of traversed elements with each iteration.
Also note that with your style of programming using Seq operators followed by Seq.cache has a small advantage over using List or Array operators: this avoids allocating intermediate data structures, which reduces GC pressure and may speed things up a bit.
See comments and all, but this code runs like hell - with both List.* and some other smaller optimisations:
let GetNeighbours p w h =
let (f1, f2, f3, f4) = p > w, p % w <> 1, p % w <> 0, p < w * (h - 1)
[
p - w - 1, f1 && f2
p - w, f1
p - w + 1, f1 && f3
p - 1, f2
p + 1, f3
p + w - 1, f4 && f2
p + w, f4
p + w + 1, f4 && f3
]
|> List.choose (fun (s, t) -> if t then Some s else None)
let rec Evolve B S CC g =
let w = 10
let h = 10
let OutputStr = sprintf "Generation %d: %A" g CC // LINE_MARKER_1
printfn "%s" OutputStr
let CCN = CC |> List.map (fun s -> s, GetNeighbours s w h)
let Survivors =
CCN
|> List.choose (fun (s, t) ->
let t =
t
|> List.filter (fun u -> CC |> List.exists ((=) u))
|> List.length
if S |> List.exists ((=) t) then
Some s
else None)
let NewBorns =
CCN
|> List.collect snd
|> List.filter (not << fun s -> CC |> List.exists ((=) s))
|> Seq.countBy id
|> List.ofSeq
|> List.choose (fun (s, t) ->
if B |> List.exists ((=) t) then
Some s
else None)
let NC = List.append Survivors NewBorns
let SWt = new System.Threading.SpinWait()
SWt.SpinOnce()
if System.Console.KeyAvailable then
match (System.Console.ReadKey()).Key with
| System.ConsoleKey.Q -> ()
| _ -> Evolve B S NC (g + 1)
else
Evolve B S NC (g + 1)
let B = [3]
let S = [2; 3]
let IC = [4; 13; 14]
let g = 0
Evolve B S IC g
Just thought I would add a simple answer, in case other beginners like me run into the same problem.
As advised by Ramon Snir, ildjarn and pad above, I changed the Seq.X calls to List.X. I had to add a simple extra casting step to account for the fact that List does not have groupBy, but having done that, the code now runs like a charm!
Thanks a lot.
One of the most amazing characteristics of the ML family of languages is that short code is often fast code and this applies to F# too.
Compare your implementation with the much faster one I blogged here:
let count (a: _ [,]) x y =
let m, n = a.GetLength 0, a.GetLength 1
let mutable c = 0
for x=x-1 to x+1 do
for y=y-1 to y+1 do
if x>=0 && x<m && y>=0 && y<n && a.[x, y] then
c <- c + 1
if a.[x, y] then c-1 else c
let rule (a: _ [,]) x y =
match a.[x, y], count a x y with
| true, (2 | 3) | false, 3 -> true
| _ -> false