A => Base.hs +168 -0
@@ 0,0 1,168 @@
+module Base (a2b,f2g,g2f,bmult,badd,bdiv,bsub) where
+
+import Numeric
+import Char
+--import Debug.Trace
+
+-- Convert an integer in one base to a number in a second.
+-- Assumes that both numbers are normalized
+a2b :: Int -> Int -> String -> String
+a2b b1 b2 str = reverse $ _a2b b2 $ toInt (reverse str)
+ where
+ toInt [] = 0
+ toInt (x:xs) = (ordVal x) + b1 * (toInt xs)
+_a2b :: Int -> Int -> String
+_a2b b 0 = ""
+_a2b b x = (chrVal $ x `mod` b) : (_a2b b $ x `div` b)
+
+-- Convert a floating point number to base b
+f2g :: Int -> String -> String
+f2g b n = (ipn $ a2b 10 b k) ++ "." ++ (_f2g b $ frac n)
+ where
+ ipn "" = "0"
+ ipn x = x
+ frac x = '0' : (dropWhile (\z -> z /= '.') x)
+ k = numerator n
+_f2g b n | (read n::Float) > 0 = ip ++ (_f2g b fp)
+ | otherwise = ""
+ where
+ pf = properFraction ((read n::Float) * (fromIntegral b))
+ ip = a2b 10 b $ show $ fst pf
+ fp = show $ snd $ pf
+
+g2f b xs | '.' `elem` xs = _g2f b xs
+ | otherwise = _g2f b (xs++".")
+ where
+ _g2f b xs =
+ fromIntegral
+ (foldr
+ (\x y -> ordVal x + b * y)
+ 0 $ reverse $ numerator xs) +
+ (foldr
+ (\x y -> (fromIntegral $ ordVal x) + y / (fromIntegral b))
+ 0 $ "0" ++ (denominator xs))
+
+-- Multiply two base b numbers
+bmult :: Int -> String -> String -> String
+bmult b x y = rshift
+ (mymult (reverse $ delDec x) (reverse $ delDec y) b)
+ (countdec x + countdec y)
+ where
+ rshift xs 0 = xs
+ rshift xs n = reverse ((take n f) ++ "." ++ (drop n $ reverse xs))
+ where
+ zeros = '0':zeros
+ f = reverse xs ++ zeros
+ delDec xs = (numerator xs) ++ (rest $ denominator xs)
+ rest [] = []
+ rest (x:xs) = xs
+ mymult _ [] b = "0"
+ mymult x (y:[]) b = _mult x (ordVal y) b "" 0
+ mymult x (y:ys) b = badd b (_mult x (ordVal y) b "" 0) (lshift (mymult x ys b))
+ where
+ lshift [] = "0"
+ lshift ('.':n:ns) = n:'.':ns
+ lshift ('.':n) = n
+ lshift (n:ns) = n:(lshift ns)
+ _mult :: String -> Int -> Int -> String -> Int -> String
+ _mult [] _ _ acc 0 = acc
+ _mult [] _ _ acc r = (chrVal r) : acc
+ _mult ('.':xs) y b acc r = _mult xs y b ('.' : acc) r
+ _mult (x:xs) y b acc r = _mult xs y b (o : acc) r1
+ where
+ res = (ordVal x) * y + r
+ o = chrVal $ res `mod` b
+ r1 = res `div` b
+
+-- Add two base b numbers
+badd :: Int -> String -> String -> String
+badd b x y = _add (reverse $ fst pad) (reverse $ snd pad) b "" 0
+ where
+ -- The following 2 functions add zeros to the fractional part
+ -- of a number. This is used to ensure that two numbers have
+ -- the same fractional length
+ fill xs n | elem '.' xs = xs ++ [ '0' | _ <- [1..n] ]
+ | otherwise = xs ++ "." ++ [ '0' | _ <- [1..n] ]
+ pad | countdec x > countdec y = (x, fill y (countdec x - countdec y))
+ | countdec x < countdec y = (fill x (countdec y - countdec x), y)
+ | otherwise = (x,y)
+ _add [] [] b acc 0 = acc
+ _add [] [] b acc r = (chrVal r) : acc
+ _add [] ys b acc r = _add ys ((chrVal r):"") b acc 0
+ _add xs [] b acc r = _add xs ((chrVal r):"") b acc 0
+ _add ('.':xs) (y:ys) b acc r = _add xs ys b ('.':acc) r
+ _add (x:xs) (y:ys) b acc r = _add xs ys b (o:acc) r1
+ where
+ res = (ordVal x) + (ordVal y) + r
+ o = chrVal $ res `mod` b
+ r1 = res `div` b
+
+-- TODO: calculate to digits+1 and round last digit
+bdiv :: Int -> Int -> String -> String -> String
+bdiv b digits x y | head final == '.' = '0':final
+ | last final == '.' = final ++ "0"
+ | otherwise = final
+ where
+ final = dropWhile (\n -> n == '0') $ reshift result q
+ result = reverse $ _div (nofrac x ++ zeros) (toInt y) "0" ""
+ toInt k = n2i $ nofrac k
+ nofrac k = (numerator k) ++ (denominator k)
+ q = (length (numerator x)) + (length $ denominator y)
+ nshift k = length (denominator k)
+ zeros = '0':zeros
+ n2i x = read $ (a2b b 10 x)::Int
+ reshift xs n | n > 0 = (take n $ xs++zeros) ++ '.':(drop n xs)
+ | otherwise = "0."++xs
+ _div :: String -> Int -> String -> String -> String
+ _div (x:xs) y num acc | nnum == 0 || length acc > digits = (chrVal k):acc
+ | otherwise = _div xs y (a2b 10 b $ show nnum) ((chrVal k):acc)
+ where
+ anum = n2i (num++x:[])
+ k = anum `div` y
+ nnum = anum - (k * y)
+
+bsub :: Int -> String -> String -> String
+bsub b x y | (nlen result) > (nlen x) = strip $ tail (badd b result (one result))
+ | stripped == "0" = "0"
+ | stripped == "0.0" = "0"
+ | otherwise = '-' : stripped
+ where
+ stripped = strip (complement result)
+ strip a@('0':'.':xs) = a
+ strip ('0':[]) = "0"
+ strip ('0':xs) = xs
+ pad = (take ((length $ numerator x)-(length $ numerator y)) ['0'|_<-[1..]]) ++ y
+ result = badd b x (complement pad)
+ nlen = length . numerator
+ complement ks = map (\n -> if n == '.' then '.' else (chrVal $ b - 1 - ordVal n)) ks
+ one (n:[]) = "1"
+ one ('.':xs) = '.': one xs
+ one (_:xs) = '0': one xs
+
+
+
+
+-- Utilities
+--
+-- Converts a number into a single character. Numbers
+-- greater than 10 are converted to ['A'..'Z']
+chrVal :: Int -> Char
+chrVal n | n >= 10 = chr $ ord 'A' + (n - 10)
+ | otherwise = chr $ ord '0' + n
+
+-- Converts a single character into a decimal number
+ordVal :: Char -> Int
+ordVal n | n >= 'a' = ord n - ord 'a' + 10
+ | n >= 'A' = ord n - ord 'A' + 10
+ | otherwise = ord n - ord '0'
+
+upcase = map (toUpper)
+
+-- Count the number of decimal places in a number
+countdec :: String -> Int
+countdec xs | elem '.' xs = length $ denominator xs
+ | otherwise = 0
+
+numerator = takeWhile (\n -> n /= '.')
+denominator xs | '.' `elem` xs = tail $ dropWhile (\n -> n /= '.') xs
+ | otherwise = ""
A => Calc.hs +45 -0
@@ 0,0 1,45 @@
+module Calc (eval) where
+
+import Parsing
+import DuoDecimal
+
+addr :: Parser String
+addr = do t <- subr
+ do symbol "+"
+ e <- addr
+ return (add t e)
+ +++ return t
+
+subr :: Parser String
+subr = do t <- mulr
+ do symbol "-"
+ e <- subr
+ return (sub t e)
+ +++ return t
+
+mulr :: Parser String
+mulr = do f <- divr
+ do symbol "*"
+ t <- mulr
+ return (mult f t)
+ +++ return f
+
+divr :: Parser String
+divr = do f <- factor
+ do symbol "/"
+ t <- divr
+ return (ddiv 10 f t)
+ +++ return f
+
+factor :: Parser String
+factor = do symbol "("
+ e <- addr
+ symbol ")"
+ return e
+ +++ natural
+
+eval :: String -> String
+eval xs = case (parse addr xs) of
+ [(n,[])] -> n
+ [(_,out)] -> error ("unused input " ++ out)
+ [] -> error "invalid input"
A => Control.hs +79 -0
@@ 0,0 1,79 @@
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Glade
+--import Graphics.UI.Gtk.TreeList.ListStore
+import Graphics.UI.Gtk.TreeList.TreeModel
+import Maybe
+import Graphics.UI.Gtk.ModelView as Mv
+
+
+import DuoDecimal
+
+main = do
+ initGUI
+ Just xml <- xmlNew "RPN.glade"
+ window <- xmlGetWidget xml castToWindow "window1"
+ entry <- xmlGetWidget xml castToEntry "entry"
+ stack <- xmlGetWidget xml castToTreeView "stack"
+
+ model <- Mv.listStoreNew []
+ Mv.treeViewSetModel stack model
+ Mv.treeViewSetHeadersVisible stack False
+ renderer <- Mv.cellRendererTextNew
+ col <- Mv.treeViewColumnNew
+ Mv.treeViewColumnPackStart col renderer True
+ Mv.cellLayoutSetAttributes col renderer model $ \row -> [ Mv.cellText := row ]
+ Mv.treeViewColumnSetTitle col "String column"
+ Mv.treeViewAppendColumn stack col
+
+ onKeyRelease entry (action entry model)
+ onEntryActivate entry (pressEnter entry model)
+ onDestroy window mainQuit
+ widgetShowAll window
+ mainGUI
+
+action e m ev = do
+ let op = case (fromMaybe ' ' $ eventKeyChar ev) of
+ '+' -> Just add
+ '-' -> Just sub
+ '*' -> Just mult
+ '/' -> Just (ddiv 10)
+ _ -> Nothing
+ in
+ if isNothing op
+ then return True
+ --then do
+ -- case (eventKeyName ev) of
+ -- "BackSpace" -> do
+ -- t <- entryGetText e
+ -- if length t == 0 then (pop m) else return True
+ -- return True
+ else do
+ remLastChar e
+ pressEnter e m
+ x <- pop m
+ y <- pop m
+ push m ((fromJust op) y x)
+ return True
+ where
+ pop m = do
+ x <- Mv.listStoreGetValue m 0
+ Mv.listStoreRemove m 0
+ return x
+
+ push m k = Mv.listStorePrepend m k
+
+ remLastChar e = do
+ entryGetText e >>= entrySetText e . reverse . tail . reverse
+
+legalChars = '.':['a'..'b']++['A'..'B']++['0'..'9']
+legal [] = False
+legal xs = foldr (\x y -> (x `elem` legalChars) && y) True xs
+
+
+pressEnter e m = do
+ t <- entryGetText e
+ if legal t
+ then Mv.listStorePrepend m t
+ else return ()
+ entrySetText e ""
+
A => DuoDecimal.hs +14 -0
@@ 0,0 1,14 @@
+module DuoDecimal (i2d,d2i,f2d,d2f,add,mult,ddiv,sub) where
+
+import Base
+
+-- Base 12 accessors
+i2d = a2b 10 12
+d2i = a2b 12 10
+f2d = f2g 12
+d2f = g2f 12
+
+mult = bmult 12
+add = badd 12
+ddiv = bdiv 12
+sub = bsub 12
A => Main.hs +47 -0
@@ 0,0 1,47 @@
+module Main (main) where
+
+import IO
+import Data.Maybe( fromMaybe )
+import System
+import System.IO
+import System.Console.GetOpt
+import DuoDecimal
+import Calc
+
+
+
+-- The "program"
+header = "USAGE: duodecimal [OPTION...]"
+main :: IO ()
+main = do
+ argv <- getArgs
+ hSetBuffering stdout NoBuffering
+ case getOpt RequireOrder options argv of
+ ([], [], []) -> error $ usageInfo header options
+ (flags, [], []) -> handle flags
+ (_, nonOpts, []) -> error $ "unrecognized arguments: " ++ unwords nonOpts
+ (_, _, msgs) -> error $ concat msgs ++ usageInfo header options
+ where
+ handle ((D2i x):_) | elem '.' x = putStrLn $ show $ d2f x
+ | otherwise = putStrLn $ d2i x
+ handle ((I2d x):_) | elem '.' x = putStrLn $ f2d x
+ | otherwise = putStrLn $ i2d x
+ handle ((Inter):_) = interactive
+ handle ((Eval x):_) = putStrLn $ eval x
+
+interactive = do
+ putStr "$ "
+ inp <- getLine
+ putStrLn $ "= " ++ (eval inp)
+ interactive
+
+data Flag = I2d String | D2i String | Inter | Eval String
+options :: [OptDescr Flag]
+options = [
+ Option "i" ["decimal"] (ReqArg I2d "DECIMAL") "convert from decimal to duodecimal",
+ Option "d" ["duodecimal"] (ReqArg D2i "DUODECIMAL") "convert from duodecimal to decimal",
+ Option "e" ["eval"] (ReqArg Eval "STRING") "evaluate a string",
+ Option "s" ["shell"] (NoArg Inter) "interactive shell"
+ ]
+
+
A => Parsing.lhs +117 -0
@@ 0,0 1,117 @@
+Functional parsing library from chapter 8 of Programming in Haskell,
+Graham Hutton, Cambridge University Press, 2007.
+
+
+> module Parsing where
+>
+> import Char
+> import Monad
+>
+> infixr 5 +++
+
+The monad of parsers
+--------------------
+
+> newtype Parser a = P (String -> [(a,String)])
+>
+> instance Monad Parser where
+> return v = P (\inp -> [(v,inp)])
+> p >>= f = P (\inp -> case parse p inp of
+> [] -> []
+> [(v,out)] -> parse (f v) out)
+>
+> instance MonadPlus Parser where
+> mzero = P (\inp -> [])
+> p `mplus` q = P (\inp -> case parse p inp of
+> [] -> parse q inp
+> [(v,out)] -> [(v,out)])
+
+Basic parsers
+-------------
+
+> failure :: Parser a
+> failure = mzero
+>
+> item :: Parser Char
+> item = P (\inp -> case inp of
+> [] -> []
+> (x:xs) -> [(x,xs)])
+>
+> parse :: Parser a -> String -> [(a,String)]
+> parse (P p) inp = p inp
+
+Choice
+------
+
+> (+++) :: Parser a -> Parser a -> Parser a
+> p +++ q = p `mplus` q
+
+Derived primitives
+------------------
+
+> sat :: (Char -> Bool) -> Parser Char
+> sat p = do x <- item
+> if p x then return x else failure
+>
+> digit :: Parser Char
+> digit = sat (\n -> n `elem` 'A':'B':['0'..'9'])
+>
+> char :: Char -> Parser Char
+> char x = sat (== x)
+>
+> string :: String -> Parser String
+> string [] = return []
+> string (x:xs) = do char x
+> string xs
+> return (x:xs)
+>
+> many :: Parser a -> Parser [a]
+> many p = many1 p +++ return []
+>
+> many1 :: Parser a -> Parser [a]
+> many1 p = do v <- p
+> vs <- many p
+> return (v:vs)
+>
+> nat :: Parser String
+> nat = do xs <- many1 digit
+> return xs
+>
+
+int :: Parser String
+int = do char '-'
+ n <- nat
+ return ('-':n)
+ +++ nat
+
+>
+> frac :: Parser String
+> frac = do k <- nat
+> char '.'
+> return (k ++ ".")
+> +++ nat
+>
+> space :: Parser ()
+> space = do many (sat isSpace)
+> return ()
+
+Ignoring spacing
+----------------
+
+> token :: Parser a -> Parser a
+> token p = do space
+> v <- p
+> space
+> return v
+>
+> natural :: Parser String
+> natural = token nat
+>
+
+integer :: Parser String
+integer = token int
+
+>
+> symbol :: String -> Parser String
+> symbol xs = token (string xs)
+
A => RPN.glade +30 -0
@@ 0,0 1,30 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!DOCTYPE glade-interface SYSTEM "glade-2.0.dtd">
+<!--Generated with glade3 3.1.4 on Tue May 15 07:43:17 2007 by ser@bean-->
+<glade-interface>
+ <widget class="GtkWindow" id="window1">
+ <property name="default_width">316</property>
+ <property name="default_height">279</property>
+ <child>
+ <widget class="GtkVBox" id="vbox1">
+ <property name="visible">True</property>
+ <child>
+ <widget class="GtkEntry" id="entry">
+ <property name="visible">True</property>
+ </widget>
+ <packing>
+ <property name="expand">False</property>
+ </packing>
+ </child>
+ <child>
+ <widget class="GtkTreeView" id="stack">
+ <property name="visible">True</property>
+ </widget>
+ <packing>
+ <property name="position">1</property>
+ </packing>
+ </child>
+ </widget>
+ </child>
+ </widget>
+</glade-interface>
A => duodecimal.rb +130 -0
@@ 0,0 1,130 @@
+class DuoDecimal
+ def initialize( str_rep )
+ case str_rep
+ when Array
+ @val = str_rep
+ when String
+ @val = str_rep.upcase.split("")
+ when Symbol
+ @val = str_rep.to_s.upcase.split("")
+ when Integer
+ @val = from_i( str_rep )
+ when Float
+ @val = from_f( str_rep, 10 )
+ else
+ @val = from_i( str_rep.to_i )
+ end
+ end
+
+ def from_i( val )
+ return [0] if val == 0
+ rv = []
+ while val > 0
+ val,k = val.divmod(12)
+ rv.unshift(k > 9 ? (k > 10 ? "B" : "A") : k)
+ end
+ rv
+ end
+
+ def to_i
+ i = @val.index('.') || @val.length
+ s = 0
+ @val.inject(0) {|s,v|
+ i -= 1
+ break if v == "."
+ s + (case v
+ when "A"; 10
+ when "B"; 11
+ else ; v.to_i
+ end) * (12 ** i)
+ }
+ s
+ end
+
+ def to_f
+ i = @val.index('.') || @val.length
+ @val.inject(0) {|s,v|
+ next s if v == "."
+ i -= 1
+ s + (case v
+ when "A"; 10
+ when "B"; 11
+ else ; v.to_i
+ end) * (12 ** i)
+ }
+ end
+
+ def from_f( other, scale=10 )
+ float = other.to_f
+ ip = float.to_i
+ res = from_i( ip )
+ float -= ip
+ res << "." if float > 0
+ while float > 0
+ float = 12 * float
+ ip = float.to_i
+ res << (ip > 9 ? (ip > 10 ? "B" : "A") : ip)
+ float -= ip
+ end
+ res
+ end
+
+ def +(other)
+ DuoDecimal.new(to_f + other.to_f)
+ end
+
+ def -(other)
+ DuoDecimal.new(to_f - other.to_f)
+ end
+
+ def divmod( other )
+ n,d = to_f.divmod( other.to_f )
+ [DuoDecimal.new(n), DuoDecimal.new(d)]
+ end
+
+ def *( other )
+ DuoDecimal.new(from_f(to_f * other.to_f))
+ end
+
+ def <=>( other )
+ to_f <=> other.to_f
+ end
+
+ def >(other)
+ (self <=> other) > 0
+ end
+ def <(other)
+ (self <=> other) < 0
+ end
+ def ==(other)
+ (self <=> other) == 0
+ end
+
+ def /( other, places=10 )
+ ipart,rem = divmod( other )
+ if rem > 0
+ rv = []
+ places.times {
+ rem *= 12
+ p,rem = rem.divmod(other)
+ rv << p
+ break if rem == 0
+ }
+ DuoDecimal.new( ipart.to_s + "." + rv.join('') )
+ else
+ ipart
+ end
+ end
+
+ def **( other )
+ DuoDecimal.new(from_f(to_f ** other.to_f))
+ end
+
+ def to_s
+ @val.join("")
+ end
+end
+
+if $0 == __FILE__
+ puts DuoDecimal.new( ARGV[0].to_f )
+end