«K12/K13» Surreal.hs «PDF», «POD»

{-# OPTIONS_GHC -fglasgow-exts #-}
module Surreal where

import Base
import Data.Set (Set)
import qualified Data.Set as Set (empty, singleton, elems, map, union, fold)
import Data.List
import EqClass
import Hyper

data Surreal = Surreal (Set Surreal) (Set Surreal)

constr :: Set Surreal -> Set Surreal -> Surreal
constr ls rs | null $ filter (\(l,r) -> r <= l) [(l,r) | l <- Set.elems ls, r <- Set.elems rs] = Surreal ls rs
constr ls rs = error $ "Malformed surreal number: {" ++ show ls ++ "|" ++ show rs ++ "}"

zero = constr Set.empty Set.empty
one  = constr (Set.singleton zero) Set.empty
_one = constr Set.empty (Set.singleton zero)
two  = constr (Set.singleton one) Set.empty
_two = constr Set.empty (Set.singleton _one)

{-
  s 0 = Set.singleton zero
  s n = 
-}

instance Show Surreal where
  show (Surreal xs ys) = fix' $ "{" ++ fix (show xs) ++ "|" ++ fix (show ys) ++ "}" where
    fix = fix' . unbrak
    unbrak "{}" = ""
    unbrak ('{':rest) | "}" `isSuffixOf` rest = init rest
    unbrak a = a
    fix' "{|}"  = "0"
    fix' "{0|}" = "1"
    fix' "{|0}" = "-1"
    fix' a      = a

instance Eq Surreal where
  x == y = x <= y && y <= x

instance Ord Surreal where
  x@(Surreal xl xr) <= y@(Surreal yl yr) =
    not (any (y <=) (Set.elems xl)) && not (any (<= x) (Set.elems yr))

instance Num Surreal where
  x@(Surreal xl xr) + y@(Surreal yl yr) = constr l' r' where
    l' = (xl >>+<< y) `Set.union` (x >>+<< yl)
    r' = (xr >>+<< y) `Set.union` (x >>+<< yr)

  x@(Surreal xl xr) * y@(Surreal yl yr) = constr l' r' where
    l' = (xl >>*<< y >>+<< x >>*<< yl >>-<< xl >>*<< yl) `Set.union`
         (xr >>*<< y >>+<< x >>*<< yr >>-<< xr >>*<< yr)
    r' = (xl >>*<< y >>+<< x >>*<< yr >>-<< xl >>*<< yr) `Set.union`
         (xr >>*<< y >>+<< x >>*<< yl >>-<< xr >>*<< yl)

  negate (Surreal xl xr) = constr (Set.map negate xr) (Set.map negate xl)

  signum x | x == zero = zero
  signum x | x >  zero = one
  signum x | x <  zero = -one

  abs x | signum x >= zero = x
  abs x | signum x <  zero = -x

  fromInteger 0         = zero
  fromInteger x | x > 0 = constr (Set.singleton $ fromInteger $ x - 1) Set.empty
  fromInteger x | x < 0 = constr Set.empty (Set.singleton $ fromInteger $ x - 1)