{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, EmptyDataDecls #-}------------------------------------------------------------------------------- |-- Module : Data.Type.Binary.Internals-- Copyright : (C) 2006-2007 Edward Kmett-- License : BSD-style (see the file libraries/base/LICENSE)---- Maintainer : Edward Kmett <ekmett@gmail.com>-- Stability : experimental-- Portability : non-portable (FD and MPTC)---- Simple type-level binary numbers, positive and negative with infinite-- precision. This forms a nice commutative ring with multiplicative identity-- like we would expect from a representation for Z.---- The numbers are represented as a Boolean Ring over a countable set of-- variables, in which for every element in the set there exists an n in N-- and a b in {T,F} such that for all n'>=n in N, x_i = b.---- For uniqueness we always choose the least such n when representing numbers-- this allows us to run most computations backwards. When we can't, and such-- a fundep would be implied, we obtain it by combining semi-operations that-- together yield the appropriate class fundep list.---- Reuses T and F from the Type.Boolean as the infinite tail of the 2s-- complement binary number. ---- TODO: TDivMod, TGCD----------------------------------------------------------------------------moduleData.Type.Binary.Internals(O,I,-- T, tT,-- F, tF,TSucc,tSucc,tPred,TCBinary,TBinary,fromTBinary,-- TNot,TNeg,tNeg,TIsNegative,tIsNegative,TIsPositive,tIsPositive,TIsZero,tIsZero,TEven,tEven,TOdd,tOdd,TAdd,tAdd,tSub,TMul,tMul,TPow,tPow,-- TAnd, TOr, TXOr, TImplies,-- tAnd, tOr, tXOr, tImplies,TShift,tShift,TGetBit,tGetBit,TSetBit,tSetBit,TChangeBit,tChangeBit,TUnSetBit,tUnSetBit,TComplementBit,tComplementBit,TCountBits,tCountBits,{- TReverse, tReverse, -}TAbs,tAbs,TNF,tNF,-- put a number into normal formt2n,t2np1,-- prepend a 0 or 1-- TEq, TLt, tEq, tLt,-- from Type.SignNegative,Positive,SignZero,-- internal interfaces below here-- these require knowledge of the internal representationTShift',-- non-normalizing shifterTNF',-- case tracking normalizer for a number.TAddC',-- non-normalizing full-adderTAdd',tAdd',-- semi-adderTSub',tSub',-- semi-subTCountBits',-- sign-tracking intermediary for TCountBitsLSB,tLSB,tBSL,-- extract the LSB and tail of a numberXI,XO,-- indicates that the number can be extended-- by a I or O without leaving normal form)whereimportData.Type.BooleanimportData.Type.OrdimportData.Type.SigndataOadataIa-- | Internal closure, not exposeddataClosureclassCloseda|->ainstanceClosedClosure-- | Extracts the least significant bit of a as d and returns a'.-- Can also be used to prepend bit d onto a' obtaining a.class(TBoold)=>LSBada'|a->da',da'->ainstanceLSBFFFinstanceLSBTTTinstanceLSB(OT)FTinstanceLSB(IF)TFinstanceLSB(O(On))F(On)instanceLSB(O(In))F(In)instanceLSB(I(On))T(On)instanceLSB(I(In))T(In)tLSB::LSBada'=>a->d->a';tLSB=undefinedtBSL::LSBada'=>a'->d->a;tBSL=undefined-- | extract the lsb and assert we aren't at the long tailclassLSBada'=>Xada'|a->da',da'->a,aa'->dinstance(LSB(Oa)Fa)=>X(Oa)Fainstance(LSB(Ia)Ta)=>X(Ia)Ta-- | assert 2n != nclassLSB(Oa)Fa=>XOainstance(LSB(Oa)Fa)=>XOa-- | assert 2n+1 != nclassLSB(Ia)Ta=>XIainstance(LSB(Ia)Ta)=>XIa-- | Finds the unique successor for any normalized binary numberclassTSuccnm|n->m,m->ninstanceTSuccTFinstanceTSuccF(IF)instanceTSucc(OT)TinstanceTSucc(O(In))(I(In))instanceTSucc(O(On))(I(On))instance(TSuccnm,XIn,XOm)=>TSucc(In)(Om)tSucc::TSuccnm=>n->m;tSucc=undefinedtPred::TSuccnm=>m->n;tPred=undefined-- | Our set of digits is closed to retain the properties needed for most of the classes hereinclassTCBinaryca|a->cinstanceTCBinaryClosureFinstanceTCBinaryClosureTinstance(TCBinaryca,XOa)=>TCBinaryc(Oa)instance(TCBinaryca,XIa)=>TCBinaryc(Ia)-- | We don't want to have to carry the closure parameter around explicitly everywhere, so we-- shed it here.classTCBinaryClosurea=>TBinaryawherefromTBinary::Integralb=>a->binstanceTBinaryFwherefromTBinary_=fromInteger0instanceTBinaryTwherefromTBinary_=fromInteger(-1)instance(TBinarya,XOa)=>TBinary(Oa)wherefromTBinary_=letx=fromTBinary(undefined::a)inx+xinstance(TBinarya,XIa)=>TBinary(Ia)wherefromTBinary_=letx=fromTBinary(undefined::a)insucc(x+x)-- | Show should express a value as legal haskell.instanceTBinary(Oa)=>Show(Oa)whereshown="$(binaryE "++(show$fromTBinaryn)++")"instanceTBinary(Ia)=>Show(Ia)whereshown="$(binaryE "++(show$fromTBinaryn)++")"{-
instance Show (O F) where show n = "({-error-} O F)";
instance Show (I T) where show n = "({-error-} I T)";
instance Show (I F) where show n = "I F";
instance Show (O T) where show n = "O T";
instance (Show (I t)) => Show (O (I t)) where show n = "O (" ++ show (undefined::I t) ++ ")"
instance (Show (I t)) => Show (I (I t)) where show n = "I (" ++ show (undefined::I t) ++ ")"
instance (Show (O t)) => Show (O (O t)) where show n = "O (" ++ show (undefined::O t) ++ ")"
instance (Show (O t)) => Show (I (O t)) where show n = "I (" ++ show (undefined::O t) ++ ")"
-}-- | TNot preserves normalization triviallyinstance(TNotab)=>TNot(Oa)(Ib)instance(TNotab)=>TNot(Ia)(Ob)-- | TNeg obtains the 2s complement of a number and is reversibleclassTNegab|a->b,b->ainstance(TNotab,TSuccbc)=>TNegactNeg::TNegab=>a->b;tNeg=undefined-- | Express a corrolary to the trichotomy law, every number is either negative, positive or zero.classTrichotomyns|n->sinstanceTrichotomyTNegativeinstanceTrichotomyFSignZeroinstanceTrichotomy(IF)PositiveinstanceTrichotomy(OT)Negativeinstance(Trichotomyab,XIa)=>Trichotomy(I(Ia))binstance(Trichotomyab,XIa)=>Trichotomy(O(Ia))binstance(Trichotomyab,XOa)=>Trichotomy(I(Oa))binstance(Trichotomyab,XOa)=>Trichotomy(O(Oa))b-- | Returns true if the number is greater than zeroclassTIsPositivenb|n->binstance(Trichotomyns,TEqsPositiveb)=>TIsPositivenbtIsPositive::TIsPositivenb=>n->b;tIsPositive=undefined-- | Returns true if the number is less than zeroclassTIsNegativenb|n->binstance(Trichotomyns,TEqsNegativeb)=>TIsNegativenbtIsNegative::TIsNegativenb=>n->b;tIsNegative=undefined-- | Returns true if the number is equal to zeroclassTIsZeronb|n->binstance(Trichotomyns,TEqsSignZerob)=>TIsZeronbtIsZero::TIsZeronb=>n->b;tIsZero=undefined-- | Returns true if the lsb of the number is trueclassTEvenab|a->binstanceLSBabc=>TEvenabtEven::(TEvenab)=>a->b;tEven=undefined-- | Returns true if the lsb of the number if falseclassTOddab|a->binstance(LSBabc,TNotbb')=>TOddab'tOdd::(TOddab)=>a->b;tOdd=undefined-- | A symmetrical full adder, that does not yield normal form answers.classTAddC'abcd|abc->dinstanceTAddC'FFFFinstanceTAddC'TFTFinstanceTAddC'FTFTinstanceTAddC'TTTTinstanceTAddC'TFFTinstanceTAddC'FTTFinstanceTAddC'FFT(IF)instanceTAddC'TTF(OT)instanceTAddC'F(Oa)F(Oa)instanceTAddC'T(Oa)T(Oa)instanceTAddC'F(Ia)F(Ia)instanceTAddC'T(Ia)T(Ia)instanceTAddC'(Oa)FF(Oa)instanceTAddC'(Oa)TT(Oa)instanceTAddC'(Ia)FF(Ia)instanceTAddC'(Ia)TT(Ia)instanceTAddC'F(Oa)T(Ia)instanceTAddC'T(Ia)F(Oa)instanceTAddC'(Oa)FT(Ia)instanceTAddC'(Ia)TF(Oa)instanceTSuccab=>TAddC'F(Ia)T(Ob)instanceTSuccba=>TAddC'T(Oa)F(Ib)instanceTSuccab=>TAddC'(Ia)FT(Ob)instanceTSuccba=>TAddC'(Oa)TF(Ib)instanceTAddC'abFc=>TAddC'(Oa)(Ob)F(Oc)instanceTAddC'abFc=>TAddC'(Oa)(Ob)T(Ic)instanceTAddC'abFc=>TAddC'(Ia)(Ob)F(Ic)instanceTAddC'abTc=>TAddC'(Ia)(Ob)T(Oc)instanceTAddC'abFc=>TAddC'(Oa)(Ib)F(Ic)instanceTAddC'abTc=>TAddC'(Oa)(Ib)T(Oc)instanceTAddC'abTc=>TAddC'(Ia)(Ib)F(Oc)instanceTAddC'abTc=>TAddC'(Ia)(Ib)T(Ic)-- | Transform a number into normal form, but track whether further reductions-- may be necessary if this number is extended for efficiency.classTNF'abc|a->bcinstanceTNF'FFFinstanceTNF'TTFinstanceTNF'(OF)FFinstanceTNF'(IT)TFinstanceTNF'(IF)(IF)TinstanceTNF'(OT)(OT)Tinstance(TNF'(Oa)cb)=>TNF'(I(Oa))(Ic)Tinstance(TNF'(Ia)cb)=>TNF'(O(Ia))(Oc)Tinstance(TNF'(Ia)cb,TIfb(Ic)Td)=>TNF'(I(Ia))dbinstance(TNF'(Oa)cb,TIfb(Oc)Fd)=>TNF'(O(Oa))db-- | Shed the additional reduction parameter from TNF'classTNFab|a->binstanceTNF'abc=>TNFabtNF::TNFab=>a->b;tNF=undefinedt2n::TNF(Oa)b=>a->b;t2n=undefinedt2np1::TNF(Ia)b=>a->b;t2np1=undefined-- | Equality comparison. Note this does not equate numbers that-- are non-normalized with their normalized kin.instanceTEq(Im)(On)FinstanceTEq(Om)(In)FinstanceTEq(Om)FFinstanceTEq(Om)TFinstanceTEq(Im)TFinstanceTEq(Im)FFinstance(TEqmnb)=>TEq(Im)(In)binstance(TEqmnb)=>TEq(Om)(On)b-- | We have a total order.instance(TBoold,TNegbb',TAdd'ab'c,TIsNegativecd)=>TLtabd-- | Non-reversible addition. Kept for efficiency purposes.classTAdd'abc|ab->cinstance(TAddC'abFd,TNFdd')=>TAdd'abd'tAdd'::(TAdd'abc)=>a->b->c;tAdd'=undefined-- | Non-reversible subtraction. Kept for efficiency purposes.classTSub'abc|ab->cinstance(TNegbb',TAdd'ab'c)=>TSub'abctSub'::TSub'abc=>a->b->c;tSub'=undefined-- | Reversible adder with extra fundeps.classTAddabc|ab->c,ac->b,bc->ainstance(TAdd'abc,TNegbb',TAdd'cb'a,TNegaa',TAdd'ca'b)=>TAddabctAdd::(TAddabc)=>a->b->c;tAdd=undefinedtSub::(TAddabc)=>c->a->b;tSub=undefined-- | Multiplication: a * b = cclassTMulabc|ab->cinstanceTMulaFFinstanceTNegab=>TMulaTbinstance(TMul(Oa)bc)=>TMula(Ob)cinstance(TMul(Oa)bc,TAdd'acd)=>TMula(Ib)dtMul::TMulabc=>a->b->c;tMul=undefined-- | Exponentiation: a^b = c (only defined for non-negative exponents)classTPowabc|ab->cinstanceTPowaF(IF)instance(TPowakc,TMulccd)=>TPowa(Ok)dinstance(TPowakc,TMulccd,TMulade)=>TPowa(Ik)etPow::TPowabc=>a->b->c;tPow=undefined{-
-- | Reverse the finite head of the number. non-normalizing, needs seed sign
class TReverse'' a b c | a b -> b
instance TReverse'' F b b
instance TReverse'' T b b
instance TReverse'' a (O b) c => TReverse (O a) b c
instance TReverse'' a (I b) c => TReverse (I a) b c
-- | Reverse the finite head of a number yielding a normal form answer
class TReverse' a b | a -> b
instance (TIsNegative a b, TReverse' a b c, TNF c c') => TReverse' a c'
-- | Reverse the finite head of a number, invertably
class TReverse a b | a -> b, b -> a
instance (TReverse' a b, TReverse' b a) => TReverse a b
tReverse :: TReverse a b => a -> b; tReverse = undefined
-}-- | Return the absolute value of aclassTAbsab|a->binstance(TIsNegativeas,TNegaa',TIfsa'aa'')=>TAbsaa''tAbs::TAbsab=>a->b;tAbs=undefinedinstanceTAndF(Ib)FinstanceTAndF(Ob)FinstanceTAnd(Ia)FFinstanceTAnd(Oa)FFinstanceTAndT(Ib)(Ib)instanceTAndT(Ob)(Ob)instanceTAnd(Ia)T(Ia)instanceTAnd(Oa)T(Oa)instance(TAndabc,TNF(Ic)c')=>TAnd(Ia)(Ib)c'instance(TAndabc,TNF(Oc)c')=>TAnd(Oa)(Ib)c'instance(TAndabc,TNF(Oc)c')=>TAnd(Ia)(Ob)c'instance(TAndabc,TNF(Oc)c')=>TAnd(Oa)(Ob)c'instanceTOrF(Ib)(Ib)instanceTOrF(Ob)(Ob)instanceTOr(Ia)F(Ia)instanceTOr(Oa)F(Ia)instanceTOrT(Ib)TinstanceTOrT(Ob)TinstanceTOr(Ia)TTinstanceTOr(Oa)TTinstance(TOrabc,TNF(Ic)c')=>TOr(Ia)(Ib)c'instance(TOrabc,TNF(Ic)c')=>TOr(Oa)(Ib)c'instance(TOrabc,TNF(Ic)c')=>TOr(Ia)(Ob)c'instance(TOrabc,TNF(Oc)c')=>TOr(Oa)(Ob)c'instanceTXOr'F(Ib)(Ib)instanceTXOr'F(Ob)(Ob)instanceTXOr'(Ib)F(Ib)instanceTXOr'(Ob)F(Ob)instanceTNotbc=>TXOr'T(Ib)(Oc)instanceTNotbc=>TXOr'T(Ob)(Ic)instanceTNotbc=>TXOr'(Ib)T(Oc)instanceTNotbc=>TXOr'(Ob)T(Ic)instance(TXOr'abc,TNF(Oc)c')=>TXOr'(Ia)(Ib)c'instance(TXOr'abc,TNF(Ic)c')=>TXOr'(Ia)(Ob)c'instance(TXOr'abc,TNF(Ic)c')=>TXOr'(Oa)(Ib)c'instance(TXOr'abc,TNF(Oc)c')=>TXOr'(Oa)(Ob)c'instanceTImpliesF(Ib)TinstanceTImpliesF(Ob)TinstanceTImplies(Ia)FTinstanceTImplies(Oa)FTinstanceTImpliesT(Ib)(Ib)instanceTImpliesT(Ob)(Ob)instanceTImplies(Ia)T(Ia)instanceTImplies(Oa)T(Oa)instance(TImpliesabc,TNF(Ic)c')=>TImplies(Ia)(Ib)c'instance(TImpliesabc,TNF(Ic)c')=>TImplies(Oa)(Ib)c'instance(TImpliesabc,TNF(Ic)c')=>TImplies(Ia)(Ob)c'instance(TImpliesabc,TNF(Oc)c')=>TImplies(Oa)(Ob)c'-- | Shift a right b places obtaining c. If b is negative then we shift left.-- | TShift' does not yield normal form answers.classTShift'abc|ab->cinstanceTShift'FFFinstanceTShift'TFTinstanceTShift'(Ia)F(Ia)instanceTShift'(Oa)F(Oa)instanceTShift'(Ia)TainstanceTShift'(Oa)TainstanceTShift'FTFinstanceTShift'TTTinstance(TShift'abc,TShift'cbd)=>TShift'a(Ob)dinstance(TShift'abc,TShift'cbd)=>TShift'a(Ib)(Od)-- | Shift a right b places obtaining c in normal form.-- | If b is negative then we shift left.classTShiftabc'|ab->c'instance(TShift'abc,TNFcc')=>TShiftabc'tShift::TShiftabc=>a->b->c;tShift=undefined-- | get bit #b in a as c in {T,F}classTGetBitabc|ab->cinstance(TNegbb',TShiftab'c,LSBcde)=>TGetBitabdtGetBit::TGetBitabc=>a->b->c;tGetBit=undefined-- | set bit #b in a to T, yielding c.classTSetBitabc|ab->cinstance(TShift(IF)bc,TOracd)=>TSetBitabdtSetBit::TSetBitabc=>a->b->c;tSetBit=undefined-- | set bit #b in a to F, yielding cclassTUnSetBitabc|ab->cinstance(TShift(OT)bc,TAndacd)=>TUnSetBitabdtUnSetBit::TUnSetBitabc=>a->b->c;tUnSetBit=undefined-- | change bit #b in a to c in {T,F}, yielding d.classTChangeBitabcd|abc->dinstance(TSetBitabd,TUnSetBitabe,TIfcdef)=>TChangeBitabcftChangeBit::TChangeBitabcd=>a->b->c->d;tChangeBit=undefined-- | toggle the value of bit #b in a, yielding cclassTComplementBitabc|ab->cinstance(TShift(IF)bc,TXOr'acd)=>TComplementBitabdtComplementBit::TComplementBitabc=>a->b->c;tComplementBit=undefined-- | Count the number of bits set, but track whether the number is positive or negative-- to simplify casing. Since we may have an infinite tail of 1s, we return a negative-- number in such cases indicating how many bits are NOT set.classTCountBits'abt|at->binstanceTCountBits'TTTinstanceTCountBits'FFFinstanceTCountBits'anF=>TCountBits'(Oa)nFinstanceTCountBits'amF=>TCountBits'(Ia)mTinstance(TCountBits'anF,TSuccnm)=>TCountBits'(Ia)mFinstance(TCountBits'anF,TSuccmn)=>TCountBits'(Oa)nT-- | Count the number of bits set. Since we may have an infinite tail of 1s, we return-- a negative number in such cases indicating how many bits are NOT set.classTCountBitsab|a->binstance(TIsNegativeat,TCountBits'abt)=>TCountBitsabtCountBits::TCountBitsab=>a->b;tCountBits=undefined