module FSA3 where 

import FSA2 (while,whiler)

fp :: Eq a => (a -> a) -> a -> a 
fp f = until (\ x -> x == f x) f

fbo n = fibo (0,1,n) where 
     fibo = fp (\ (x,y,k) -> if k == 0 then (x,y,k)
                             else (y,x+y,k-1))

bab a = \ x -> ((x + a/x)/2)

sr a = fp (bab a) a

iterateFix :: Eq a => (a -> a) -> a -> [a]
iterateFix f = apprx . iterate f where
  apprx (x:y:zs) = if x == y then [x] else x: apprx (y:zs)

fix :: (a -> a) -> a
fix f = f (fix f)

fbx n = fibo (0,1,n) where
    fibo = fix (\ f (x,y,k) -> if k == 0 then (x,y,k)
                               else f (y,x+y,k-1))

fbb n = fbbb (0,1,n) where 
  fbbb (x,y,n) = if n == 0 then x else fbbb (y,x+y,n-1)

fbc n = fbbc 0 1 n where 
  fbbc x y n = if n == 0 then x else fbbc y (x+y) (n-1)

fp' :: Eq a => (a -> a) -> a -> a
fp' f = fix (\ g x -> if x == f x then x else g (f x))

until' :: (a -> Bool) -> (a -> a) -> a -> a
until' p f = fix (\ g x -> if p x then x else g (f x))

while' :: (a -> Bool) -> (a -> a) -> a -> a
while' p f = fix (\ g x -> if not (p x) then x else g (f x))

apprFact :: (Integer -> Integer) -> Integer -> Integer
apprFact = \ f n -> if n == 0 then 1 else n * f (n-1)

fact = fix apprFact

pre :: (a -> Bool) -> (a -> b) -> a -> b 
pre p f x = if p x then f x else error "pre"

post :: (b -> Bool) -> (a -> b) -> a -> b 
post p f x = if p (f x) then f x else error "post"

decomp :: Integer -> (Integer,Integer)
decomp n = decmp (0,n) where
  decmp = until (odd.snd) (\ (m,k) -> (m+1,div k 2)) 

decompPost :: Integer -> (Integer,Integer)
decompPost = \n -> post (\ (m,k) -> 2^m * k == n) decomp n

assert :: (a -> b -> Bool) -> (a -> b) -> a -> b 
assert p f x = if p x (f x) then f x else error "assert"

decompA :: Integer -> (Integer,Integer)
decompA = assert (\ n (m,k) -> 2^m * k == n) decomp

stepA :: (Integer, Integer) ->  (Integer, Integer)
stepA = assert (\ (m,k) (m',k') -> 2^m*k == 2^m'*k')
                (\ (m,k) -> (m+1,div k 2))

invar :: (a -> Bool) -> (a -> a) -> a -> a
invar p f x = 
  let 
    x' = f x 
  in
   if p x && not (p x') then error "invar" else x'

succI = invar (>0) succ

predI = invar (<0) pred

largestOddFactor =  while even (invar (>0) (`div` 2))

predI' = invar (>0) pred

ext_gcd :: Integer -> Integer -> (Integer,Integer) 
ext_gcd a b = ext_gcd' (a,b,0,1,1,0) where
    ext_gcd' = whiler 
                 (\ (_,b,_,_,_,_) ->  b /= 0) 
                 (\ (a,b,x,y,lastx,lasty) -> let 
                    (q,r)   = quotRem a b 
                    (x',lastx') = (lastx-q*x,x)
                    (y',lasty') = (lasty-q*y,y)
                 in (b,r,x',y',lastx',lasty'))
                 (\ (_,_,_,_,lx,ly) -> (lx,ly))

bezout :: Integer -> Integer -> (Integer,Integer) -> Bool
bezout m n (x,y) = x*m + y*n == euclid m n 

euclid m n = fst $ eucl (m,n) where
     eucl = until (uncurry  (==))
         (\ (x,y) -> if x > y then (x-y,x) else (x,y-x))

ext_gcdA = assert2 bezout ext_gcd

assert2 ::  (a -> b -> c -> Bool) 
             -> (a -> b -> c) -> a -> b -> c
assert2 p f x y = 
  if p x y (f x y) then f x y
  else error "assert2"

fct_gcd :: Integer -> Integer -> (Integer,Integer) 
fct_gcd a b = 
  if b == 0 
  then (1,0) 
  else 
     let 
       (q,r) = quotRem a b
       (s,t) = fct_gcd b r 
     in (t, s - q*t)

fct_gcdA = assert2 bezout fct_gcd