summaryrefslogtreecommitdiff
path: root/progs/lib/hbc
diff options
context:
space:
mode:
Diffstat (limited to 'progs/lib/hbc')
-rw-r--r--progs/lib/hbc/Either.hs2
-rw-r--r--progs/lib/hbc/Either.hu3
-rw-r--r--progs/lib/hbc/Hash.hs79
-rw-r--r--progs/lib/hbc/Hash.hu3
-rw-r--r--progs/lib/hbc/ListUtil.hs48
-rw-r--r--progs/lib/hbc/ListUtil.hu4
-rw-r--r--progs/lib/hbc/Maybe.hs6
-rw-r--r--progs/lib/hbc/Maybe.hu3
-rw-r--r--progs/lib/hbc/Miranda.hs90
-rw-r--r--progs/lib/hbc/Miranda.hu4
-rw-r--r--progs/lib/hbc/Option.hs3
-rw-r--r--progs/lib/hbc/Option.hu3
-rw-r--r--progs/lib/hbc/Pretty.hs50
-rw-r--r--progs/lib/hbc/Printf.hs150
-rw-r--r--progs/lib/hbc/Printf.hu3
-rw-r--r--progs/lib/hbc/QSort.hs47
-rw-r--r--progs/lib/hbc/QSort.hu3
-rw-r--r--progs/lib/hbc/README97
-rw-r--r--progs/lib/hbc/Random.hs52
-rw-r--r--progs/lib/hbc/Random.hu3
-rw-r--r--progs/lib/hbc/Time.hs51
-rw-r--r--progs/lib/hbc/Time.hu3
22 files changed, 707 insertions, 0 deletions
diff --git a/progs/lib/hbc/Either.hs b/progs/lib/hbc/Either.hs
new file mode 100644
index 0000000..fad5af8
--- /dev/null
+++ b/progs/lib/hbc/Either.hs
@@ -0,0 +1,2 @@
+module Either(Either(..)) where
+data Either a b = Left a | Right b deriving (Eq, Ord, Text, Binary)
diff --git a/progs/lib/hbc/Either.hu b/progs/lib/hbc/Either.hu
new file mode 100644
index 0000000..3313235
--- /dev/null
+++ b/progs/lib/hbc/Either.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Either.hs
diff --git a/progs/lib/hbc/Hash.hs b/progs/lib/hbc/Hash.hs
new file mode 100644
index 0000000..1f14c6f
--- /dev/null
+++ b/progs/lib/hbc/Hash.hs
@@ -0,0 +1,79 @@
+module Hash where
+--
+-- Hash a value. Hashing produces an Int of
+-- unspecified range.
+--
+
+class Hashable a where
+ hash :: a -> Int
+
+instance Hashable Char where
+ hash x = ord x
+
+instance Hashable Int where
+ hash x = x
+
+instance Hashable Integer where
+ hash x = fromInteger x
+
+instance Hashable Float where
+ hash x = truncate x
+
+instance Hashable Double where
+ hash x = truncate x
+
+instance Hashable Bin where
+ hash x = 0
+
+{-instance Hashable File where
+ hash x = 0 -}
+
+instance Hashable () where
+ hash x = 0
+
+instance Hashable (a -> b) where
+ hash x = 0
+
+instance Hashable a => Hashable [a] where
+ hash x = sum (map hash x)
+
+instance (Hashable a, Hashable b) => Hashable (a,b) where
+ hash (a,b) = hash a + 3 * hash b
+
+instance (Hashable a, Hashable b, Hashable c) => Hashable (a,b,c) where
+ hash (a,b,c) = hash a + 3 * hash b + 5 * hash c
+
+instance (Hashable a, Hashable b, Hashable c, Hashable d) => Hashable (a,b,c,d) where
+ hash (a,b,c,d) = hash a + 3 * hash b + 5 * hash c + 7 * hash d
+
+instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) => Hashable (a,b,c,d,e) where
+ hash (a,b,c,d,e) = hash a + hash b + hash c + hash d + hash e
+
+instance Hashable Bool where
+ hash False = 0
+ hash True = 1
+
+instance (Integral a, Hashable a) => Hashable (Ratio a) where
+ hash x = hash (denominator x) + hash (numerator x)
+
+instance (RealFloat a, Hashable a) => Hashable (Complex a) where
+ hash (x :+ y) = hash x + hash y
+
+instance (Hashable a, Hashable b) => Hashable (Assoc a b) where
+ hash (x := y) = hash x + hash y
+
+instance (Ix a) => Hashable (Array a b) where
+ hash x = 0 -- !!!
+
+instance Hashable Request where
+ hash x = 0 -- !!
+
+instance Hashable Response where
+ hash x = 0 -- !!
+
+instance Hashable IOError where
+ hash x = 0 -- !!
+
+hashToMax maxhash x =
+ let h = abs (hash x)
+ in if h < 0 then 0 else h `rem` maxhash
diff --git a/progs/lib/hbc/Hash.hu b/progs/lib/hbc/Hash.hu
new file mode 100644
index 0000000..2c23c72
--- /dev/null
+++ b/progs/lib/hbc/Hash.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Hash.hs
diff --git a/progs/lib/hbc/ListUtil.hs b/progs/lib/hbc/ListUtil.hs
new file mode 100644
index 0000000..560920e
--- /dev/null
+++ b/progs/lib/hbc/ListUtil.hs
@@ -0,0 +1,48 @@
+module ListUtil(assoc, concatMap, unfoldr, mapAccuml, union, intersection, chopList, assocDef, lookup, Maybe..) where
+import Maybe
+
+-- Lookup an item in an association list. Apply a function to it if it is found, otherwise return a default value.
+assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b
+assoc f d [] x = d
+assoc f d ((x',y):xys) x | x' == x = f y
+ | otherwise = assoc f d xys x
+
+-- Map and concatename results.
+concatMap :: (a -> [b]) -> [a] -> [b]
+concatMap f [] = []
+concatMap f (x:xs) =
+ case f x of
+ [] -> concatMap f xs
+ ys -> ys ++ concatMap f xs
+
+-- Repeatedly extract (and transform) values until a predicate hold. Return the list of values.
+unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
+unfoldr f p x | p x = []
+ | otherwise = y:unfoldr f p x'
+ where (y, x') = f x
+
+-- Map, but plumb a state through the map operation.
+mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
+mapAccuml f s [] = (s, [])
+mapAccuml f s (x:xs) = (s'', y:ys)
+ where (s', y) = f s x
+ (s'', ys) = mapAccuml f s' xs
+
+-- Union of sets as lists.
+union :: (Eq a) => [a] -> [a] -> [a]
+union xs ys = xs ++ (ys \\ xs)
+
+-- Intersection of sets as lists.
+intersection :: (Eq a) => [a] -> [a] -> [a]
+intersection xs ys = [x | x<-xs, x `elem` ys]
+
+--- Functions derived from those above
+
+chopList :: ([a] -> (b, [a])) -> [a] -> [b]
+chopList f l = unfoldr f null l
+
+assocDef :: (Eq a) => [(a, b)] -> b -> a -> b
+assocDef l d x = assoc id d l x
+
+lookup :: (Eq a) => [(a, b)] -> a -> Maybe b
+lookup l x = assoc Just Nothing l x
diff --git a/progs/lib/hbc/ListUtil.hu b/progs/lib/hbc/ListUtil.hu
new file mode 100644
index 0000000..7402cb7
--- /dev/null
+++ b/progs/lib/hbc/ListUtil.hu
@@ -0,0 +1,4 @@
+:output $LIBRARYBIN/
+:o= all
+ListUtil.hs
+Maybe.hu
diff --git a/progs/lib/hbc/Maybe.hs b/progs/lib/hbc/Maybe.hs
new file mode 100644
index 0000000..f0ada70
--- /dev/null
+++ b/progs/lib/hbc/Maybe.hs
@@ -0,0 +1,6 @@
+module Maybe(Maybe(..), thenM) where
+-- Maybe together with Just and thenM forms a monad, but is more
+-- by accident than by design.
+data Maybe a = Nothing | Just a deriving (Eq, Ord, Text, Binary)
+Nothing `thenM` _ = Nothing
+Just a `thenM` f = f a
diff --git a/progs/lib/hbc/Maybe.hu b/progs/lib/hbc/Maybe.hu
new file mode 100644
index 0000000..a55b652
--- /dev/null
+++ b/progs/lib/hbc/Maybe.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Maybe.hs
diff --git a/progs/lib/hbc/Miranda.hs b/progs/lib/hbc/Miranda.hs
new file mode 100644
index 0000000..2d863ce
--- /dev/null
+++ b/progs/lib/hbc/Miranda.hs
@@ -0,0 +1,90 @@
+module Miranda(cjustify, lay, layn, limit, ljustify, merge, rep, rjustify, spaces,
+ {-force,seq,-}sort) where
+--import UnsafeDirty
+import QSort
+
+cjustify :: Int -> String -> String
+cjustify n s = spaces l ++ s ++ spaces r
+ where
+ m = n - length s
+ l = m `div` 2
+ r = m - l
+
+{-
+index :: [a] -> [Int]
+index xs = f xs 0
+ where f [] n = []
+ f (_:xs) n = n : f xs (n+1)
+-}
+
+lay :: [String] -> String
+lay = concat . map (++"\n")
+
+layn :: [String] -> String
+layn = concat . zipWith f [1..]
+ where
+ f :: Int -> String -> String
+ f n x = rjustify 4 (show n) ++ ") " ++ x ++ "\n"
+
+limit :: (Eq a) => [a] -> a
+limit (x:y:ys) | x == y = x
+ | otherwise = limit (y:ys)
+limit _ = error "Miranda.limit: bad use"
+
+ljustify :: Int -> String -> String
+ljustify n s = s ++ spaces (n - length s)
+
+merge :: (Ord a) => [a] -> [a] -> [a]
+merge [] ys = ys
+merge xs [] = xs
+merge xxs@(x:xs) yys@(y:ys) | x <= y = x : merge xs yys
+ | otherwise = y : merge xxs ys
+
+rep :: Int -> b -> [b]
+rep n x = take n (repeat x)
+
+rjustify :: Int -> String -> String
+rjustify n s = spaces (n - length s) ++ s
+
+spaces :: Int -> String
+spaces 0 = ""
+spaces n = ' ' : spaces (n-1)
+
+-------------
+
+arctan x = atan x
+code c = ord c
+converse f a b = flip f a b
+decode n = chr n
+digit c = isDigit c
+e :: (Floating a) => a
+e = exp 1
+entier x = floor x
+filemode f = error "Miranda.filemode"
+--getenv
+hd xs = head xs
+hugenum :: (Floating a) => a
+hugenum = error "hugenum" --!!!
+integer x = x == truncate x
+letter c = isAlpha c
+map2 f xs ys = zipWith f xs ys
+--max
+max2 x y = max x y
+member xs x = x `elem` xs
+--min
+min2 x y = min x y
+mkset xs = nub xs
+neg x = negate x
+numval :: (Num a) => String -> a
+numval cs = read cs
+postfix xs x = xs ++ [x]
+--read
+scan f z l = scanl f z l
+--shownum !!!
+--showfloat !!!
+--showscaled !!!
+tinynum :: (Floating a) => a
+tinynum = error "tinynum"
+undef = error "undefined"
+zip2 xs ys = zip xs ys
+--zip
diff --git a/progs/lib/hbc/Miranda.hu b/progs/lib/hbc/Miranda.hu
new file mode 100644
index 0000000..cfa86ed
--- /dev/null
+++ b/progs/lib/hbc/Miranda.hu
@@ -0,0 +1,4 @@
+:output $LIBRARYBIN/
+:o= all
+Miranda.hs
+QSort.hu
diff --git a/progs/lib/hbc/Option.hs b/progs/lib/hbc/Option.hs
new file mode 100644
index 0000000..a4b2423
--- /dev/null
+++ b/progs/lib/hbc/Option.hs
@@ -0,0 +1,3 @@
+module Option(Option(..), thenO) where
+import Maybe renaming (Maybe to Option, Nothing to None, Just to Some, thenM to thenO)
+
diff --git a/progs/lib/hbc/Option.hu b/progs/lib/hbc/Option.hu
new file mode 100644
index 0000000..592a0cd
--- /dev/null
+++ b/progs/lib/hbc/Option.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Option.hs
diff --git a/progs/lib/hbc/Pretty.hs b/progs/lib/hbc/Pretty.hs
new file mode 100644
index 0000000..ad63dbe
--- /dev/null
+++ b/progs/lib/hbc/Pretty.hs
@@ -0,0 +1,50 @@
+module Pretty(text, separate, nest, pretty, (~.), (^.), IText(..), Context(..)) where
+infixr 8 ~.
+infixr 8 ^.
+
+type IText = Context -> [String]
+type Context = (Bool,Int,Int,Int)
+
+text :: String -> IText
+text s (v,w,m,m') = [s]
+
+(~.) :: IText -> IText -> IText
+(~.) d1 d2 (v,w,m,m') =
+ let t = d1 (False,w,m,m')
+ tn = last t
+ indent = length tn
+ sig = if length t == 1
+ then m' + indent
+ else length (dropWhile (==' ') tn)
+ (l:ls) = d2 (False,w-indent,m,sig)
+ in init t ++
+ [tn ++ l] ++
+ map (space indent++) ls
+
+space :: Int -> String
+space n = [' ' | i<-[1..n]]
+
+(^.) :: IText -> IText -> IText
+(^.) d1 d2 (v,w,m,m') = d1 (True,w,m,m') ++ d2 (True,w,m,0)
+
+separate :: [IText] -> IText
+separate [] _ = [""]
+separate ds (v,w,m,m') =
+ let hor = foldr1 (\d1 d2 -> d1 ~. text " " ~. d2) ds
+ ver = foldr1 (^.) ds
+ t = hor (v,w,m,m')
+ in if fits 1 t && fits (w `min` m-m') (head t)
+ then t
+ else ver (v,w,m,m')
+
+fits n xs = length xs <= n `max` 0 --null (drop n xs)
+
+nest :: Int -> IText -> IText
+nest n d (v,w,m,m') =
+ if v then
+ map (space n++) (d (v,w-n,m,if m'==0 then 0 else m'+n))
+ else
+ d (v,w,m,m')
+
+pretty :: Int->Int->IText->String
+pretty w m d = concat (map (++"\n") (d (False,w,m,0)))
diff --git a/progs/lib/hbc/Printf.hs b/progs/lib/hbc/Printf.hs
new file mode 100644
index 0000000..c8291bd
--- /dev/null
+++ b/progs/lib/hbc/Printf.hs
@@ -0,0 +1,150 @@
+-- This code used a function in the lml library (fmtf) that I don't have.
+-- If someone makes this work for floats let me know -- jcp
+--
+-- A C printf like formatter.
+-- Conversion specs:
+-- - left adjust
+-- num field width
+-- . separates width from precision
+-- Formatting characters:
+-- c Char, Int, Integer
+-- d Char, Int, Integer
+-- o Char, Int, Integer
+-- x Char, Int, Integer
+-- u Char, Int, Integer
+-- f Float, Double
+-- g Float, Double
+-- e Float, Double
+-- s String
+--
+module Printf(UPrintf(..), printf) where
+
+-- import LMLfmtf
+
+data UPrintf = UChar Char |
+ UString String |
+ UInt Int |
+ UInteger Integer |
+ UFloat Float |
+ UDouble Double
+
+printf :: String -> [UPrintf] -> String
+printf "" [] = ""
+printf "" (_:_) = fmterr
+printf ('%':_) [] = argerr
+printf ('%':cs) us@(_:_) = fmt cs us
+printf (c:cs) us = c:printf cs us
+
+fmt :: String -> [UPrintf] -> String
+fmt cs us =
+ let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
+ adjust (pre, str) =
+ let lstr = length str
+ lpre = length pre
+ fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
+ in if ladj then pre ++ str ++ fill else pre ++ fill ++ str
+ in
+ case cs' of
+ [] -> fmterr
+ c:cs'' ->
+ case us' of
+ [] -> argerr
+ u:us'' ->
+ (case c of
+ 'c' -> adjust ("", [chr (toint u)])
+ 'd' -> adjust (fmti u)
+ 'x' -> adjust ("", fmtu 16 u)
+ 'o' -> adjust ("", fmtu 8 u)
+ 'u' -> adjust ("", fmtu 10 u)
+ '%' -> "%"
+ 'e' -> adjust (dfmt c prec (todbl u))
+ 'f' -> adjust (dfmt c prec (todbl u))
+ 'g' -> adjust (dfmt c prec (todbl u))
+ 's' -> adjust ("", tostr u)
+ c -> perror ("bad formatting char " ++ [c])
+ ) ++ printf cs'' us''
+unimpl = perror "unimplemented"
+
+fmti (UInt i) = if i < 0 then
+ if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
+ else
+ ("", itos i)
+fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
+fmti (UChar c) = fmti (UInt (ord c))
+fmti u = baderr
+
+fmtu b (UInt i) = if i < 0 then
+ if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
+ else
+ itosb b (toInteger i)
+fmtu b (UInteger i) = itosb b i
+fmtu b (UChar c) = itosb b (toInteger (ord c))
+fmtu b u = baderr
+
+maxi :: Integer
+maxi = (toInteger maxInt + 1) * 2
+
+toint (UInt i) = i
+toint (UInteger i) = toInt i
+toint (UChar c) = ord c
+toint u = baderr
+
+tostr (UString s) = s
+tostr u = baderr
+
+todbl (UDouble d) = d
+todbl (UFloat f) = fromRational (toRational f)
+todbl u = baderr
+
+itos n =
+ if n < 10 then
+ [chr (ord '0' + toInt n)]
+ else
+ let (q, r) = quotRem n 10 in
+ itos q ++ [chr (ord '0' + toInt r)]
+
+chars = array (0,15) (zipWith (:=) [0..] "0123456789abcdef")
+itosb :: Integer -> Integer -> String
+itosb b n =
+ if n < b then
+ [chars!n]
+ else
+ let (q, r) = quotRem n b in
+ itosb b q ++ [chars!r]
+
+stoi :: Int -> String -> (Int, String)
+stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs
+stoi a cs = (a, cs)
+
+getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
+getSpecs l z ('-':cs) us = getSpecs True z cs us
+getSpecs l z ('0':cs) us = getSpecs l True cs us
+getSpecs l z ('*':cs) us = unimpl
+getSpecs l z cs@(c:_) us | isDigit c =
+ let (n, cs') = stoi 0 cs
+ (p, cs'') = case cs' of
+ '.':r -> stoi 0 r
+ _ -> (-1, cs')
+ in (n, p, l, z, cs'', us)
+getSpecs l z cs us = (0, -1, l, z, cs, us)
+
+-- jcp: I don't know what the lml function fmtf does. Someone needs to
+-- rewrite this.
+
+{-
+dfmt c p d =
+ case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of
+ '-':cs -> ("-", cs)
+ cs -> ("" , cs)
+-}
+dfmt = error "fmtf not implemented"
+
+perror s = error ("Printf.printf: "++s)
+fmterr = perror "formatting string ended prematurely"
+argerr = perror "argument list ended prematurely"
+baderr = perror "bad argument"
+
+-- This is needed because standard Haskell does not have toInt
+
+toInt :: Integral a => a -> Int
+toInt x = fromIntegral x
diff --git a/progs/lib/hbc/Printf.hu b/progs/lib/hbc/Printf.hu
new file mode 100644
index 0000000..d94f5b1
--- /dev/null
+++ b/progs/lib/hbc/Printf.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Printf.hs
diff --git a/progs/lib/hbc/QSort.hs b/progs/lib/hbc/QSort.hs
new file mode 100644
index 0000000..f19eb43
--- /dev/null
+++ b/progs/lib/hbc/QSort.hs
@@ -0,0 +1,47 @@
+{-
+ This module implements a sort function using a variation on
+ quicksort. It is stable, uses no concatenation and compares
+ only with <=.
+
+ sortLe sorts with a given predicate
+ sort uses the <= method
+
+ Author: Lennart Augustsson
+-}
+
+module QSort(sortLe, sort) where
+sortLe :: (a -> a -> Bool) -> [a] -> [a]
+sortLe le l = qsort le l []
+
+sort :: (Ord a) => [a] -> [a]
+sort l = qsort (<=) l []
+
+-- qsort is stable and does not concatenate.
+qsort le [] r = r
+qsort le [x] r = x:r
+qsort le (x:xs) r = qpart le x xs [] [] r
+
+-- qpart partitions and sorts the sublists
+qpart le x [] rlt rge r =
+ -- rlt and rge are in reverse order and must be sorted with an
+ -- anti-stable sorting
+ rqsort le rlt (x:rqsort le rge r)
+qpart le x (y:ys) rlt rge r =
+ if le x y then
+ qpart le x ys rlt (y:rge) r
+ else
+ qpart le x ys (y:rlt) rge r
+
+-- rqsort is as qsort but anti-stable, i.e. reverses equal elements
+rqsort le [] r = r
+rqsort le [x] r = x:r
+rqsort le (x:xs) r = rqpart le x xs [] [] r
+
+rqpart le x [] rle rgt r =
+ qsort le rle (x:qsort le rgt r)
+rqpart le x (y:ys) rle rgt r =
+ if le y x then
+ rqpart le x ys (y:rle) rgt r
+ else
+ rqpart le x ys rle (y:rgt) r
+
diff --git a/progs/lib/hbc/QSort.hu b/progs/lib/hbc/QSort.hu
new file mode 100644
index 0000000..9a07dd1
--- /dev/null
+++ b/progs/lib/hbc/QSort.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+QSort.hs
diff --git a/progs/lib/hbc/README b/progs/lib/hbc/README
new file mode 100644
index 0000000..c51452a
--- /dev/null
+++ b/progs/lib/hbc/README
@@ -0,0 +1,97 @@
+These libraries are adapted from the lml library. Also included are a number
+of Common Lisp functions.
+
+The hbc library contains the following modules and functions:
+
+* module Either
+ binary sum data type
+ data Either a b = Left a | Right b
+ constructor Left typically used for errors
+
+* module Option
+ type for success or failure
+ data Option a = None | Some a
+ thenO :: Option a -> (a -> Option b) -> Option b apply a function that may fail
+
+
+* module ListUtil
+ Various useful functions involving lists that are missing from the Prelude
+ assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b
+ assoc f d l k looks for k in the association list l, if it is found f is applied to the value, otherwise d is returned
+ concatMap :: (a -> [b]) -> [a] -> [b]
+ flattening map (LMLs concmap)
+ unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
+ unfoldr f p x repeatedly applies f to x until (p x) holds. (f x) should give a list element and a new x
+ mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
+ mapAccuml f s l maps f over l, but also threads the state s though (LMLs mapstate)
+ union :: (Eq a) => [a] -> [a] -> [a]
+ unions of two lists
+ intersection :: (Eq a) => [a] -> [a] -> [a]
+ intersection of two lists
+ chopList :: ([a] -> (b, [a])) -> [a] -> [b]
+ LMLs choplist
+ assocDef :: (Eq a) => [(a, b)] -> b -> a -> b
+ LMLs assocdef
+ lookup :: (Eq a) => [(a, b)] -> a -> Option b
+ lookup l k looks for the key k in the association list l and returns an optional value
+
+* module Pretty
+ John Hughes pretty printing library.
+ type Context = (Bool, Int, Int, Int)
+ type IText = Context -> [String]
+ text :: String -> IText just text
+ (~.) :: IText -> IText -> IText horizontal composition
+ (^.) :: IText -> IText -> IText vertical composition
+ separate :: [IText] -> IText separate by spaces
+ nest :: Int -> IText -> IText indent
+ pretty :: Int -> Int -> IText -> String format it
+
+* module QSort
+ Sort function using quicksort.
+ sortLe :: (a -> a -> Bool) -> [a] -> [a] sort le l sorts l with le as less than predicate
+ sort :: (Ord a) => [a] -> [a] sort l sorts l using the Ord class
+
+* module Random
+ Random numbers.
+ randomInts :: Int -> Int -> [Int] given two seeds gives a list of random Int
+ randomDoubles :: Int -> Int -> [Double] given two seeds gives a list of random Double
+
+* module RunDialogue
+ Test run programs of type Dialogue.
+ Only a few Requests are implemented, unfortunately not ReadChannel.
+ run :: Dialogue -> String just run the program, showing the output
+ runTrace :: Dialogue -> String run the program, showing each Request and Response
+
+* module Miranda
+ Functions found in the Miranda(tm) library.
+
+* module Printf
+ C printf style formatting. Handles same types as printf in C, but requires the arguments
+ to be tagged. Useful for formatting of floating point values.
+ data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
+ printf :: String -> [UPrintf] -> String convert arguments in the list according to the formatting string
+
+
+* module Time
+ Manipulate time values (a Double with seconds since 1970).
+ -- year mon day hour min sec dec-sec weekday
+ data Time = Time Int Int Int Int Int Int Double Int
+ dblToTime :: Double -> Time convert a Double to a Time
+ timeToDbl :: Time -> Double convert a Time to a Double
+ timeToString :: Time -> String convert a Time to a readable String
+
+----- To add:
+
+Bytes
+IO Library
+Word oprtations
+Time clock stuff
+Lisp stuff: symbols
+ hashtables
+ strings
+
+
+
+
+
+
diff --git a/progs/lib/hbc/Random.hs b/progs/lib/hbc/Random.hs
new file mode 100644
index 0000000..269d6af
--- /dev/null
+++ b/progs/lib/hbc/Random.hs
@@ -0,0 +1,52 @@
+{-
+ This module implements a (good) random number generator.
+
+ The June 1988 (v31 #6) issue of the Communications of the ACM has an
+ article by Pierre L'Ecuyer called, "Efficient and Portable Combined
+ Random Number Generators". Here is the Portable Combined Generator of
+ L'Ecuyer for 32-bit computers. It has a period of roughly 2.30584e18.
+
+ Transliterator: Lennart Augustsson
+-}
+
+module Random(randomInts, randomDoubles) where
+-- Use seeds s1 in 1..2147483562 and s2 in 1..2147483398 to generate
+-- an infinite list of random Ints.
+randomInts :: Int -> Int -> [Int]
+randomInts s1 s2 =
+ if 1 <= s1 && s1 <= 2147483562 then
+ if 1 <= s2 && s2 <= 2147483398 then
+ rands s1 s2
+ else
+ error "randomInts: Bad second seed."
+ else
+ error "randomInts: Bad first seed."
+
+rands :: Int -> Int -> [Int]
+rands s1 s2 =
+ let
+ k = s1 `div` 53668
+ s1' = 40014 * (s1 - k * 53668) - k * 12211
+ s1'' = if s1' < 0 then s1' + 2147483563 else s1'
+
+ k' = s2 `div` 52774
+ s2' = 40692 * (s2 - k' * 52774) - k' * 3791
+ s2'' = if s2' < 0 then s2' + 2147483399 else s2'
+
+ z = s1'' - s2''
+{-
+ z' = if z < 1 then z + 2147483562 else z
+
+ in z' : rands s1'' s2''
+-}
+-- Use this instead; it is a little stricter and generates much better code
+ in if z < 1 then z + 2147483562 : rands s1'' s2''
+ else z : rands s1'' s2''
+
+-- For those of you who don't have fromInt
+fromInt = fromInteger . toInteger
+
+-- Same values for s1 and s2 as above, generates an infinite
+-- list of Doubles uniformly distibuted in (0,1).
+randomDoubles :: Int -> Int -> [Double]
+randomDoubles s1 s2 = map (\x -> fromInt x * 4.6566130638969828e-10) (randomInts s1 s2)
diff --git a/progs/lib/hbc/Random.hu b/progs/lib/hbc/Random.hu
new file mode 100644
index 0000000..9fff34e
--- /dev/null
+++ b/progs/lib/hbc/Random.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Random.hs
diff --git a/progs/lib/hbc/Time.hs b/progs/lib/hbc/Time.hs
new file mode 100644
index 0000000..29f3441
--- /dev/null
+++ b/progs/lib/hbc/Time.hs
@@ -0,0 +1,51 @@
+module Time(Time(..), dblToTime, timeToDbl, timeToString) where
+-- year mon day hour min sec ... wday
+data Time = Time Int Int Int Int Int Int Double Int deriving (Eq, Ord, Text)
+
+isleap :: Int -> Bool
+isleap n = n `rem` 4 == 0 -- good enough for the UNIX time span
+
+daysin :: Int -> Int
+daysin n = if isleap n then 366 else 365
+
+monthlen :: Array (Bool, Int) Int
+monthlen = array ((False, 1), (True, 12)) (zipWith3 (\ a b c -> (a,b):=c) (repeat False) [1..] [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] ++
+ zipWith3 (\ a b c -> (a,b):=c) (repeat True) [1..] [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31])
+
+-- Time zone offset in minutes
+tzOffset = 120 -- Swedish DST
+
+dblToTime :: Double -> Time
+dblToTime d =
+ let t = truncate d :: Int
+ offset = tzOffset -- timezone
+ (days, rem) = (t+offset*60) `quotRem` (60*60*24)
+ (hour, rem') = rem `quotRem` (60*60)
+ (min, sec) = rem' `quotRem` 60
+ wday = (days+3) `mod` 7
+ (year, days')= until (\ (y, d) -> d < daysin y) (\ (y, d) -> (y+1, d - daysin y)) (1970, days)
+ (mon, day) = until (\ (m, d) -> d <= monthlen!(isleap year, m)) (\ (m, d) -> (m+1, d - monthlen!(isleap year, m))) (1, days')
+ in Time year mon (day+1) hour min sec (d - fromInt t) wday
+
+timeToDbl :: Time -> Double
+timeToDbl (Time year mon day hour min sec sdec _) =
+ let year' = year - 1970
+ offset = tzOffset -- timezone
+ days = year' * 365 + (year'+1) `div` 4 +
+ sum [monthlen!(isleap year, m) | m<-[1..mon-1]] + day - 1
+ secs = ((days*24 + hour) * 60 + min - offset) * 60 + sec
+ in fromInt secs + sdec
+
+show2 :: Int -> String
+show2 x = [chr (x `quot` 10 + ord '0'), chr (x `rem` 10 + ord '0')]
+
+weekdays = ["Mon","Tue","Wen","Thu","Fri","Sat","Sun"]
+
+timeToString :: Time -> String
+timeToString (Time year mon day hour min sec sdec wday) =
+ show year ++ "-" ++ show2 mon ++ "-" ++ show2 day ++ " " ++
+ show2 hour ++ ":" ++ show2 min ++ ":" ++ show2 sec ++
+ tail (take 5 (show sdec)) ++ " " ++ weekdays!!wday
+
+-- For those of you who don't have fromInt
+fromInt = fromInteger . toInteger
diff --git a/progs/lib/hbc/Time.hu b/progs/lib/hbc/Time.hu
new file mode 100644
index 0000000..01c8f64
--- /dev/null
+++ b/progs/lib/hbc/Time.hu
@@ -0,0 +1,3 @@
+:output $LIBRARYBIN/
+:o= all
+Time.hs
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-19 01:12:35 +0000