Evening all... I appear to have broken hat-trans... Stephan Kahrs
sent me this program to try hat-delta on, but it appears that hat
barfs before I even get that far...
lappybob:~/Documents/Work/Hat test cases/Hell Sort tatd2$ hmake -hat
hellSort
hat-trans hellSort.hs
Creating directories Hat
Wrote Hat/hellSort.hs
ghc -c -package hat -o Hat/hellSort.o Hat/hellSort.hs
ghc -package hat -o hellSort Hat/hellSort.o
lappybob:~/Documents/Work/Hat test cases/Hell Sort tatd2$ ./hellSort
[6,4,2,9,10,9,3]
> [2,3,4,6,9,10,9]
^CKilled
lappybob:~/Documents/Work/Hat test cases/Hell Sort tatd2$ hat-detect
hellSort
hat-detect (error): file hellSort.hat is too short
lappybob:~/Documents/Work/Hat test cases/Hell Sort tatd2$ hat-check
hellSort
hat-check (error): file hellSort.hat is too short
Begin forwarded message:
> From: "S.M.Kahrs" <S.M.Kahrs(a)kent.ac.uk>
> Date: 16 September 2005 15:34:07 BDT
> To: tatd2(a)kent.ac.uk
> Cc: S.M.Kahrs(a)kent.ac.uk
> Subject: buggy sorting function
>
>
> The sorting function is called 'treesort'.
>
> module Main where
> {- Ulrich Furbach, Lothar Schmitz -}
>
> treesort :: Ord a => [a] -> [a]
> treesort = sort . establish
>
> establish f = eaux (length f) ((0,[1]),f)
>
> eaux n a@((u,ss),f) =
> let sm = head ss
> sm1 = ss !! 1
> sm2 = ss !! 2
> in
> if u==n-1 then ((u,ss),siftav a)
> else if u>=sm && sm == pre sm1 then eaux n ((u+1,((sm+sm1
> +1):drop 2 ss)),siftbin((u,sm),f))
> else if n-u>=pre sm then eaux n((u+1,1:ss),siftbin((u,sm),f))
> else eaux n((u+1,1:ss), siftav((u,ss),f))
>
> sort ((u,ss),f) =
> if u==0 then take 1 f
> else sort (rearrange((u,ss),f)) ++ [f !! u]
>
> rearrange((u,sm:ss),f) =
> if sm==1 then ((u-1,ss),f)
> else ((u-1,tt),siftsp((u-1,tt),siftsp((u-1-tlast,tt0),f)))
> where
> tt0 = t1: ss
> tt = tlast: tt0
> (tlast,t1)=preaux sm 0 1 1
> sm1 = ss !! 0
> sm2 = ss !! 1
>
> siftsp ((u,ss),f) =
> let sm = head ss
> sm1 = ss !! 1
> sm2 = ss !! 2
> m = length ss
> in
> if m==1 || (f !! (u-sm)) <= (f !! u) then f
> else siftav ((u-sm,tail ss),swap f (u-sm)u)
>
> siftav((u,ss),f) =
> if u<sm || (f !! (u-sm))<= (f !! u) then siftbin((u,sm),f)
> else if sm==1 || (f !! g)<= (f !! (u-sm)) then siftav((u-
> sm,tail ss),swap f (u-sm) u)
> else siftbin ((g,sg),swap f u g)
> where
> (p2,p1)=preaux sm 0 1 1
> (g,sg)= if (f !! (u-1))<=(f !!(u-1-p2)) then (u-1-p2,p1)
> else (u-1,p2)
> sm = head ss
> sm1 = ss !! 1
> sm2 = ss !! 2
>
>
> siftbin ((u,s),f) =
> if s==1 || (f !! g)<=(f!! u) then f
> else siftbin((g,sg),swap f g u)
> where
> (p2,p1)=preaux s 0 1 1
> (g,sg)= if (f !! (u-1))<= (f !!(u-1-p2)) then (u-1-p2,p1)
> else (u-1,p2)
>
>
> swap :: [a] -> Int -> Int -> [a]
> swap xs i j = if i>j then swap' xs j i else swap' xs i j
> swap' :: [a] -> Int -> Int -> [a]
> swap' xs i j = {- i<j -}
> let (a,b)=splitAt i xs
> (c,d)=splitAt (j-i) b
> in a++[head d]++ tail c ++ [head c] ++ tail d
>
>
> pre n = snd (preaux n 0 1 1)
>
> preaux n a b c = if n<=c then (a,b)
> else preaux n b c (b+c+1)
>
>
> tsort :: [Int] -> [Int]
> tsort = treesort
>
> main =
> do
> putStr "> "
> xs <- getLine
> if null xs then return ()
> else ( print (tsort (read xs))) >> main
>
