-- integers reimplemented in binary
module Bin where {

import Data.Monoid;

-- definition, smart constructors

data Bin = Zero | Mone | Oh Bin | One Bin
	deriving Show;

oh :: Bin -> Bin;
oh Zero = Zero;
oh x = Oh x;

one :: Bin -> Bin;
one Mone = Mone;
one x = One x;

-- conversion from and to numbers

fromBin :: (Num i) => Bin -> i;
fromBin Zero = 0;
fromBin Mone = -1;
fromBin (Oh x) = 2 * fromBin x;
fromBin (One x) = 1 + 2 * fromBin x;

toBin :: (Integral i) => i -> Bin;
toBin x = let { h = toBin (div x 2); } in
	if 0 == x then Zero else
	if -1 == x then Mone else
	if odd x then one h else oh h;

-- comparision

cmpBin :: Bin -> Bin -> Ordering;
cmpBin Zero Zero = EQ;
cmpBin Zero Mone = GT;
cmpBin Zero (Oh y) = cmpBin Zero y;
cmpBin Zero (One y) = mappend (cmpBin Zero y) LT;
cmpBin Mone Zero = LT;
cmpBin Mone Mone = EQ;
cmpBin Mone (Oh y) = mappend (cmpBin Mone y) GT;
cmpBin Mone (One y) = cmpBin Mone y;
cmpBin (Oh x) Zero = cmpBin x Zero;
cmpBin (Oh x) Mone = mappend (cmpBin x Mone) LT;
cmpBin (Oh x) (Oh y) = cmpBin x y;
cmpBin (Oh x) (One y) = mappend (cmpBin x y) LT;
cmpBin (One x) Zero = mappend (cmpBin x Zero) GT;
cmpBin (One x) Mone = cmpBin x Mone;
cmpBin (One x) (Oh y) = mappend (cmpBin x y) GT;
cmpBin (One x) (One y) = cmpBin x y;

ltBin :: Bin -> Bin -> Bool;
ltBin x y = LT == cmpBin x y;

eqBin :: Bin -> Bin -> Bool;
eqBin x y = EQ == cmpBin x y;

-- addittion and subtraction

addBin :: Bin -> Bin -> Bin;
addBin Zero Zero = Zero;
addBin Zero Mone = Mone;
addBin Zero (Oh y) = oh (addBin Zero y);
addBin Zero (One y) = one (addBin Zero y);
addBin Mone Zero = Mone;
addBin Mone Mone = oh Mone;
addBin Mone (Oh y) = one (addBin Mone y);
addBin Mone (One y) = oh (add1Bin Mone y);
addBin (Oh x) Zero = oh (addBin x Zero);
addBin (Oh x) Mone = one (addBin x Mone);
addBin (Oh x) (Oh y) = oh (addBin x y);
addBin (Oh x) (One y) = one (addBin x y);
addBin (One x) Zero = one (addBin x Zero);
addBin (One x) Mone = oh (add1Bin x Mone);
addBin (One x) (Oh y) = one (addBin x y);
addBin (One x) (One y) = oh (add1Bin x y);

add1Bin :: Bin -> Bin -> Bin;
add1Bin Zero Zero = one Zero;
add1Bin Zero Mone = Zero;
add1Bin Zero (Oh y) = one (addBin Zero y);
add1Bin Zero (One y) = oh (add1Bin Zero y);
add1Bin Mone Zero = Zero;
add1Bin Mone Mone = Mone;
add1Bin Mone (Oh y) = oh (add1Bin Mone y);
add1Bin Mone (One y) = one (add1Bin Mone y);
add1Bin (Oh x) Zero = one (addBin x Zero);
add1Bin (Oh x) Mone = oh (add1Bin x Mone);
add1Bin (Oh x) (Oh y) = one (addBin x y);
add1Bin (Oh x) (One y) = oh (add1Bin x y);
add1Bin (One x) Zero = oh (add1Bin x Zero);
add1Bin (One x) Mone = one (add1Bin x Mone);
add1Bin (One x) (Oh y) = oh (add1Bin x y);
add1Bin (One x) (One y) = one (add1Bin x y);

subBin :: Bin -> Bin -> Bin;
subBin Zero Zero = Zero;
subBin Zero Mone = one Zero;
subBin Zero (Oh y) = oh (subBin Zero y);
subBin Zero (One y) = one (sub1Bin Zero y);
subBin Mone Zero = Mone;
subBin Mone Mone = Zero;
subBin Mone (Oh y) = one (subBin Mone y);
subBin Mone (One y) = oh (subBin Mone y);
subBin (Oh x) Zero = oh (subBin x Zero);
subBin (Oh x) Mone = one (sub1Bin x Mone);
subBin (Oh x) (Oh y) = oh (subBin x y);
subBin (Oh x) (One y) = one (sub1Bin x y);
subBin (One x) Zero = one (subBin x Zero);
subBin (One x) Mone = oh (subBin x Mone);
subBin (One x) (Oh y) = one (subBin x y);
subBin (One x) (One y) = oh (subBin x y);

sub1Bin :: Bin -> Bin -> Bin;
sub1Bin Zero Zero = Mone;
sub1Bin Zero Mone = Zero;
sub1Bin Zero (Oh y) = one (sub1Bin Zero y);
sub1Bin Zero (One y) = oh (sub1Bin Zero y);
sub1Bin Mone Zero = oh Mone;
sub1Bin Mone Mone = Mone;
sub1Bin Mone (Oh y) = oh (subBin Mone y);
sub1Bin Mone (One y) = one (sub1Bin Mone y);
sub1Bin (Oh x) Zero = one (sub1Bin x Zero);
sub1Bin (Oh x) Mone = oh (sub1Bin x Mone);
sub1Bin (Oh x) (Oh y) = one (sub1Bin x y);
sub1Bin (Oh x) (One y) = oh (sub1Bin x y);
sub1Bin (One x) Zero = oh (subBin x Zero);
sub1Bin (One x) Mone = one (sub1Bin x Mone);
sub1Bin (One x) (Oh y) = oh (subBin x y);
sub1Bin (One x) (One y) = one (sub1Bin x y);

-- convenience functions

zeroBin :: Bin;
zeroBin = Zero;

oneBin :: Bin;
oneBin = one Zero;

twoBin :: Bin;
twoBin = oh (one Zero);

tenBin :: Bin;
tenBin = oh (one (oh (one Zero)));

minusOneBin :: Bin;
minusOneBin = Mone;

negateBin :: Bin -> Bin;
negateBin x = subBin Zero x;

complementBin :: Bin -> Bin;
complementBin x = sub1Bin Zero x;

succBin :: Bin -> Bin;
succBin x = add1Bin Zero x;

predBin :: Bin -> Bin;
predBin x = sub1Bin x Zero;

signBin :: Bin -> Ordering;
signBin x = cmpBin x Zero;

nonnegBin :: Bin -> Bool;
nonnegBin x = LT /= signBin x;

posBin :: Bin -> Bool;
posBin x = GT == signBin x;

-- multiplication

mulBin :: Bin -> Bin -> Bin;
mulBin Zero y = Zero;
mulBin Mone y = subBin Zero y;
mulBin (Oh x) y = oh (mulBin x y);
mulBin (One x) y = addBin y (oh (mulBin x y));

-- integer division

divMod0Bin :: Bin -> Bin -> (Bin, Bin);
divMod0Bin x y =
	if ltBin x y 
	then (Zero, x)
	else let { (d, m) = divMod0Bin x (oh y); } 
	in if ltBin m y then (oh d, m) else (one d, subBin m y);

divMod1Bin :: Bin -> Bin -> (Bin, Bin);
divMod1Bin x y = 
	if nonnegBin x 
	then divMod0Bin x y
	else let { (d, m) = divMod0Bin (complementBin x) y } 
	in (complementBin d, sub1Bin y m);

divModBin :: Bin -> Bin -> (Bin, Bin);
divModBin x y =
	case signBin y of {
		EQ -> error "division by zero";
		GT -> divMod1Bin x y;
		LT -> let { 
			(d, m) = divMod1Bin (negateBin x) (negateBin y); 
		} in (d, negateBin m);
	};

divBin :: Bin -> Bin -> Bin;
divBin x y = fst (divModBin x y);

modBin :: Bin -> Bin -> Bin;
modBin x y = snd (divModBin x y);

-- show in decimal

show0Bin :: Bin -> String;
show0Bin x =
	if posBin x
	then let { (d, m) = divModBin x tenBin; } in toEnum (fromEnum '0' + fromBin m) : show0Bin d
	else "";
	
show1Bin :: Bin -> String;
show1Bin x = reverse (show0Bin x);

showBin :: Bin -> String;
showBin x = 
	case signBin x of { 
		LT -> '-' : show1Bin (negateBin x);
		EQ -> "0";
		GT -> show1Bin x;
	};

-- wrapper to the standard classes

newtype BinInteger = BinInteger { getBinInteger :: Bin };

instance Eq BinInteger where {
	(BinInteger x) == (BinInteger y) = eqBin x y;
};

instance Ord BinInteger where {
	compare (BinInteger x) (BinInteger y) = cmpBin x y;
};

instance Enum BinInteger where {
	succ (BinInteger x) = BinInteger (succBin x);
	pred (BinInteger x) = BinInteger (predBin x);
	toEnum x = BinInteger (toBin x);
	fromEnum (BinInteger x) = fromBin x;
	enumFrom = iterate succ;
	enumFromThen n m = iterate (+(m-n)) n;
	enumFromTo n m = takeWhile (<= m) (enumFrom n);
	enumFromThenTo n n' m = takeWhile p (enumFromThen n n') where {
		p | n <= n' = (<= m) | otherwise = (>= m);
	};
};

instance Show BinInteger where {
	show (BinInteger x) = showBin x;
};

instance Num BinInteger where {
	(BinInteger x) + (BinInteger y) = BinInteger (addBin x y);
	(BinInteger x) - (BinInteger y) = BinInteger (subBin x y);
	(BinInteger x) * (BinInteger y) = BinInteger (mulBin x y);
	negate (BinInteger x) = BinInteger (negateBin x);
	abs (BinInteger x) = 
		BinInteger (if nonnegBin x then x else negateBin x);
	signum (BinInteger x) = 
		BinInteger (case signBin x of { LT -> minusOneBin; EQ -> zeroBin; GT -> oneBin; });
	fromInteger x = BinInteger (toBin x);
};

instance Real BinInteger where {
	toRational (BinInteger x) = fromBin x;
};

instance Integral BinInteger where {
	divMod (BinInteger x) (BinInteger y) =
		let { (d, m) = divModBin x y; } in (BinInteger x, BinInteger y);
	div (BinInteger x) (BinInteger y) = BinInteger (divBin x y);
	mod (BinInteger x) (BinInteger y) = BinInteger (modBin x y);
	quotRem x y = 
		if 0 <= x then divMod x y else let { (d, m) = divMod (-x) (-y) } in (-d, -m);
	toInteger (BinInteger x) = fromBin x;
};

-- factorial

fac :: BinInteger -> BinInteger;
fac n = product [1..n];

-- main

main :: IO ();
main = print (fac 10);

}