-- |
-- = TTFwH 第3章 数値
--
module TFwH.Chap03
  ( -- * 3 数値
    -- ** 3.1 型クラスNum
    -- ** 3.2 名前と演算子
    -- ** 3.3 床値の計算
    floorS
  , floor0n
  , floor0p
    -- *** 二分探索
  , floor1
  , shrink
  , choose
  , bound
  , lower
  , upper
    -- ** 3.4 自然数
  , Nat (..)
  ) where

import Prelude hiding (floor)
import Numeric


lt :: Float -> Integer -> Bool
x `lt` n = x < fromInteger n

leq :: Integer -> Float -> Bool
m `leq` x = fromInteger m <= x

-- |
-- 尻高版 floor
--
floorS :: Float -> Integer
floorS = read . takeWhile (/= '.') . show

-- |
-- 最初の素朴な版 floor (負値)
-- 
floor0n :: Float -> Integer
floor0n x = until (`leq` x) (subtract 1) (-1)

-- |
-- 最初の素朴な版 floor (非負値)
-- 
floor0p :: Float -> Integer
floor0p x = until (x `lt`)  (+ 1) 1 - 1

-- |
-- 最初の素朴な版 floor
--
floor0 x = if x < 0
  then until (`leq` x) (subtract 1) (-1)
  else until (x `lt`) (+ 1) 1 - 1

-- |
-- 二分探索版 floor
--
floor1 :: Float -> Integer
floor1 x = fst (until unit (shrink x) (bound x))
           where
             unit (m, n) = m + 1 == n

type Interval = (Integer, Integer)

-- |
-- 区間の縮小
shrink :: Float -> Interval -> Interval
shrink x (m, n) = if p `leq` x then (p, n) else (m, p)
                  where
                    p = choose (m, n)

-- |
-- 新しい境界の選択
choose :: Interval -> Integer
choose (m, n) = (m + n) `div` 2

-- |
-- 最初の区間
bound :: Float -> Interval
bound x = (lower x, upper x)

-- |
-- 最初の下側境界
lower :: Float -> Integer
lower x = until (`leq` x) (* 2) (-1)

-- |
-- 最初の上側境界
upper :: Float -> Integer
upper x = until (x `lt`) (*2) 1

-- |
-- 自然数
data Nat = Zero | Succ Nat
  deriving (Eq, Ord, Show)

-- |
-- Num クラスのインスタンス
--
instance Num Nat where
  m + Zero   = m
  m + Succ n = Succ (m + n)

  m * Zero   = Zero
  m * Succ n = m * n + m

  abs n = n

  signum Zero     = Zero
  signum (Succ n) = Succ Zero

  m - Zero        = m
  Zero - Succ n   = Zero
  Succ m - Succ n = m - n

  fromInteger x
    | x <= 0    = Zero
    | otherwise = Succ (fromInteger (x - 1))