Hi,
Please find code attached. Please CC me on replies as I'm not
subscribed. I would have added this via trac but couldn't log in (was
endlessly prompted for username/password and guest/guest didn't make it
go away).
This is to do with strictness modifiers: if you remove all the ! from
the code then the bug vanishes.
Also, the following works fine:
buildOctTree (Vec 0 0 0) 10 10 10 [(a,(Vec a a a)) | a <- [(-4.0),(-2.0)..4.0]]
Also, having done that, the problematic expressions work fine - the bug
only appears if the expression below is run as the first call to
buildOctTree in the ghci session.
This is on a P4, 2GB RAM, Debian unstable, ghc 6.6 (both hand rolled and
from debian).
uname -a =
Linux smudge 2.6.18-2-686 #1 SMP Wed Nov 8 19:52:12 UTC 2006 i686 GNU/Linux
> ghci -v OctTree
___ ___ _
/ _ \ /\ /\/ __(_)
/ /_\// /_/ / / | | GHC Interactive, version 6.6, for Haskell 98.
/ /_\\/ __ / /___| | http://www.haskell.org/ghc/
\____/\/ /_/\____/|_| Type :? for help.
Using package config file: /usr/lib/ghc-6.6/package.conf
wired-in package base mapped to base-2.0
wired-in package rts mapped to rts-1.0
wired-in package haskell98 mapped to haskell98-1.0
wired-in package template-haskell mapped to template-haskell-2.0
Hsc static flags: -static
Loading package base ... linking ... done.
*** Parser:
*** Desugar:
*** Simplify:
*** CorePrep:
*** ByteCodeGen:
*** Parser:
*** Desugar:
*** Simplify:
*** CorePrep:
*** ByteCodeGen:
*** Chasing dependencies:
Stable obj: []
Stable BCO: []
unload: retaining objs []
unload: retaining bcos []
Upsweep completely successful.
*** Deleting temp files:
Deleting:
*** Chasing dependencies:
Stable obj: []
Stable BCO: []
unload: retaining objs []
unload: retaining bcos []
compile: input file OctTree.hs
*** Checking old interface for main:OctTree:
[1 of 1] Compiling OctTree ( OctTree.hs, interpreted )
*** Parser:
*** Renamer/typechecker:
*** Desugar:
Result size = 1587
*** Simplify:
Result size = 2390
Result size = 2137
Result size = 2105
Result size = 2100
*** Tidy Core:
Result size = 2198
*** CorePrep:
Result size = 2646
*** ByteCodeGen:
*** Deleting temp files:
Deleting:
Upsweep completely successful.
*** Deleting temp files:
Deleting:
Ok, modules loaded: OctTree.
*OctTree> buildOctTree (Vec 0 0 0) 10 10 10 [(a,(Vec a a a)) | a <-
[(-4.0),(-3.9)..4.0]]
*** Parser:
*** Desugar:
*** Simplify:
*** CorePrep:
*** ByteCodeGen:
<interactive>: internal error: interpretBCO: unknown or unimplemented opcode
20196
(GHC version 6.6 for i386_unknown_linux)
Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug
Aborted
Matthew
--
Matthew Sackman
http://www.wellquite.org/
{-
- OctTrees.hs: Implementation of OctTrees in Haskell
- Copyright (C) 2006 Matthew Sackman
-
- This program is free software; you can redistribute it and/or
- modify it under the terms of the GNU General Public License
- as published by the Free Software Foundation; version 2
- of the License only.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
-}
module OctTree
(OctTree,
buildOctTree,
findInRadius
)
where
import Data.List
data Vector = Vec !Double !Double !Double
deriving (Show, Eq)
findDisplacement :: Vector -> Vector -> (Double, Vector)
findDisplacement (Vec ax ay az) (Vec bx by bz) =
(len, Vec dx dy dz)
where
len = sqrt ((dx*dx) + (dy*dy) + (dz*dz))
dx = (bx - ax)
dy = (by - ay)
dz = (bz - az)
-- lne usw
data OctTree value = OctTree !Vector !Vector !(OctTreeNode value)
deriving (Show)
data OctTreeNode value = EmptyLeaf
-- pos value
| Leaf !Vector !(value)
| Node
-- lne lse lsw lnw
!(OctTree value) !(OctTree value) !(OctTree value) !(OctTree value)
-- unw usw use une
!(OctTree value) !(OctTree value) !(OctTree value) !(OctTree value)
deriving (Show)
buildOctTree :: (Show a) => Vector -> Double -> Double -> Double -> [(a,Vector)] -> (OctTree a)
buildOctTree (Vec mx my mz) x_size y_size z_size values = foldl' (\t (v,pos) -> insertValue t v pos) initial values
where
initial = OctTree (Vec (mx+x) (my+y) (mz-z)) (Vec (mx-x) (my-y) (mz+z)) EmptyLeaf
x = x_size /2
y = y_size /2
z = z_size /2
insertValue :: (Show a) => (OctTree a) -> a -> Vector -> (OctTree a)
insertValue (OctTree lnePos uswPos EmptyLeaf) value pos = OctTree lnePos uswPos (Leaf pos value)
insertValue (OctTree lnePos@(Vec lne_x lne_y lne_z) uswPos@(Vec usw_x usw_y usw_z) (Leaf pos1 v1)) v2 pos2 = n3
where
n1 = OctTree lnePos uswPos (Node lne lse lsw lnw unw usw use une)
n2 = insertValue n1 v1 pos1
n3 = insertValue n2 v2 pos2
middle@(Vec mx my mz) = (Vec ((lne_x + usw_x)/2) ((lne_y + usw_y)/2) ((lne_z + usw_z)/2))
lne = OctTree lnePos middle EmptyLeaf
lse = OctTree (Vec lne_x my lne_z) (Vec mx usw_y mz) EmptyLeaf
lsw = OctTree (Vec mx my lne_z) (Vec usw_x usw_y mz) EmptyLeaf
lnw = OctTree (Vec mx lne_y lne_z) (Vec usw_x my mz) EmptyLeaf
unw = OctTree (Vec mx lne_y mz) (Vec usw_x my usw_z) EmptyLeaf
usw = OctTree middle uswPos EmptyLeaf
use = OctTree (Vec lne_x my mz) (Vec mx usw_y usw_z) EmptyLeaf
une = OctTree (Vec lne_x lne_y mz) (Vec mx my usw_z) EmptyLeaf
insertValue n@(OctTree lnePos uswPos (Node lne lse lsw lnw unw usw use une))
value pos = OctTree lnePos uswPos node
where
node =
case inQuadrant lne pos of
True -> (Node (insertValue lne value pos) lse lsw lnw unw usw use une)
False -> case inQuadrant lse pos of
True -> (Node lne (insertValue lse value pos) lsw lnw unw usw use une)
False -> case inQuadrant lsw pos of
True -> (Node lne lse (insertValue lsw value pos) lnw unw usw use une)
False -> case inQuadrant lnw pos of
True -> (Node lne lse lsw (insertValue lnw value pos) unw usw use une)
False -> case inQuadrant unw pos of
True -> (Node lne lse lsw lnw (insertValue unw value pos) usw use une)
False -> case inQuadrant usw pos of
True -> (Node lne lse lsw lnw unw (insertValue usw value pos) use une)
False -> case inQuadrant use pos of
True -> (Node lne lse lsw lnw unw usw (insertValue use value pos) une)
False -> case inQuadrant une pos of
True -> (Node lne lse lsw lnw unw usw use (insertValue une value pos))
False -> error $ "Value " ++ (show value) ++ " at position " ++ (show pos) ++ " is not in node " ++ (show n)
inQuadrant :: (OctTree a) -> Vector -> Bool
inQuadrant (OctTree (Vec lne_x lne_y lne_z) (Vec usw_x usw_y usw_z) _) (Vec x y z) =
(x > usw_x) && (y > usw_y) && (z < usw_z) && (x <= lne_x) && (y <= lne_y) && (z >= lne_z)
findInRadius :: OctTree a -> Vector -> Double -> [(a,Vector,Double)]
findInRadius (OctTree _ _ EmptyLeaf) _ _ = []
findInRadius (OctTree _ _ (Leaf vPos value)) from radius =
case dist <= radius of
True -> [(value, vPos, dist)]
False -> []
where
(dist,_) = findDisplacement from vPos
findInRadius (OctTree _ _ (Node lne lse lsw lnw unw usw use une)) from@(Vec fx fy fz) radius =
concat result
where
children = filter findInRadius' [lne, lse, lsw, lnw, unw, usw, use, une]
result = map (\n -> findInRadius n from radius) children
findInRadius' :: OctTree a -> Bool
findInRadius' (OctTree _ _ EmptyLeaf) = False
findInRadius' (OctTree (Vec lne_x lne_y lne_z) (Vec usw_x usw_y usw_z) _) =
((fx + radius) > usw_x) && ((fx - radius) <= lne_x) &&
((fy + radius) > usw_y) && ((fy - radius) <= lne_y) &&
((fz - radius) < usw_z) && ((fz + radius) >= lne_z)
_______________________________________________
Glasgow-haskell-bugs mailing list
Glasgow-haskell-bugs@haskell.org
http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs
