Fwd: buggy sorting function

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" <[email protected]>
> Date: 16 September 2005 15:34:07 BDT
> To: [email protected]
> Cc: [email protected]
> 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
>