Is it bug?
Serguey Zefirov
Serguey Zefirov <thesz@mail.ru>
Sun, 23 Mar 2003 04:43:09 +0300
Hello hugs-bugs-request,
Sunday, March 23, 2003, 4:25:54 AM, you wrote:
The following program:
------------------------------------
module StringSolver(
fixedp,
freep,
connstr,
solvestrings
) where
-- start end length needed
data ConnStr = ConnStr Int Int Double
type V3 = (Double,Double,Double)
data Point =
FixedP V3 -- point that cannot move
| FreeP V3 -- point that we compute.
deriving Show
connstr = ConnStr
fixedp = FixedP
freep = FreeP
step = 0.01
deltasq = d*d
where
d = step
verysmall = 0.000000000000001
sub3v (x,y,z) (x',y',z') = (x-x',y-y',z-z')
add3v (x,y,z) (x',y',z') = (x+x',y+y',z+z')
mul3vsc (x,y,z) sc = (x*sc,y*sc,z*sc)
inprod (x,y,z) (x',y',z') = x*x'+y*y'+z*z'
distsq a b = let d=sub3v a b in inprod d d
dist a b = sqrt $ distsq a b
lenv3 = dist (0,0,0)
normv3 a = let
d = lenv3 a
n = 1/sqrt(d)
in
if d<verysmall then a else mul3vsc a n
normv3step a = mul3vsc (normv3 a) (2*step)
-- We simply calculate force vectors, normalize them
-- into step length and then just add computed displacement.
-- if for all points offset is less than delta we stop
-- and return given points. otherwise we proceed further.
solvestrings points strings = let
(points',forces,deltas) = displace points strings
dists = map lenv3 deltas
smalldists = map (<=deltasq) dists
close = and smalldists
in
(points,points',forces,smalldists):
if close then [] else solvestrings points' strings
displace points strings = let
sforces = stringforces strings points
deltas = force points 0 sforces
in
(zipWith disppoint points deltas,sforces,deltas)
disppoint p@(FixedP c) delta = p
disppoint (FreeP c) delta = FreeP (add3v c delta)
pointtov3 (FixedP c) = c
pointtov3 (FreeP c) = c
stringforces [] _ = []
stringforces ((ConnStr start end needlen):ss) points = let
sp = pointtov3 $ points !! start
ep = pointtov3 $ points !! end
len = dist sp ep
-- force vector is from start point to end point
v = sub3v ep sp
vlen = lenv3 v
normmul = (vlen-needlen)/needlen
force = mul3vsc (normv3step v) normmul
in
(start,end,force):stringforces ss points
force [] _ _ = []
force (p:ps) n sforces = let
forces [] = []
forces ((start,end,v):sfs)
| start==n = v:forces sfs
| end==n = (mul3vsc v (-1)):forces sfs
| otherwise = forces sfs
f = foldl add3v (0,0,0) (forces sforces)
in
f:force ps (n+1) sforces
a = 10.0
tpoints = [
fixedp (a,0,0),
fixedp (0,a,0),
fixedp (-a,0,0),
fixedp (0,-a,0),
freep (a,a,1)
]
tstrlen = a*sqrt 2
tstrings = [
connstr 0 1 tstrlen,
connstr 1 2 tstrlen,
connstr 2 3 tstrlen,
connstr 3 0 tstrlen,
connstr 0 4 tstrlen,
connstr 1 4 tstrlen,
connstr 2 4 tstrlen,
connstr 3 4 tstrlen
]
test = ptest $ solvestrings tpoints tstrings
ptest [] = return ()
ptest (p:ps) = do
putStrLn $ show p
ptest ps
------------------------------------
gives "Garbage collection fails to reclaim sufficient space." when
loaded into Hugs Nov 2002 and asked to run "test".
I think it shouldn't do that.
--
Best regards,
Serguey
thesz na mail tochka ru
(na == at, tochka == dot)