From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 progs/lib/hbc/Either.hs   |   2 +
 progs/lib/hbc/Either.hu   |   3 +
 progs/lib/hbc/Hash.hs     |  79 ++++++++++++++++++++++++
 progs/lib/hbc/Hash.hu     |   3 +
 progs/lib/hbc/ListUtil.hs |  48 +++++++++++++++
 progs/lib/hbc/ListUtil.hu |   4 ++
 progs/lib/hbc/Maybe.hs    |   6 ++
 progs/lib/hbc/Maybe.hu    |   3 +
 progs/lib/hbc/Miranda.hs  |  90 ++++++++++++++++++++++++++++
 progs/lib/hbc/Miranda.hu  |   4 ++
 progs/lib/hbc/Option.hs   |   3 +
 progs/lib/hbc/Option.hu   |   3 +
 progs/lib/hbc/Pretty.hs   |  50 ++++++++++++++++
 progs/lib/hbc/Printf.hs   | 150 ++++++++++++++++++++++++++++++++++++++++++++++
 progs/lib/hbc/Printf.hu   |   3 +
 progs/lib/hbc/QSort.hs    |  47 +++++++++++++++
 progs/lib/hbc/QSort.hu    |   3 +
 progs/lib/hbc/README      |  97 ++++++++++++++++++++++++++++++
 progs/lib/hbc/Random.hs   |  52 ++++++++++++++++
 progs/lib/hbc/Random.hu   |   3 +
 progs/lib/hbc/Time.hs     |  51 ++++++++++++++++
 progs/lib/hbc/Time.hu     |   3 +
 22 files changed, 707 insertions(+)
 create mode 100644 progs/lib/hbc/Either.hs
 create mode 100644 progs/lib/hbc/Either.hu
 create mode 100644 progs/lib/hbc/Hash.hs
 create mode 100644 progs/lib/hbc/Hash.hu
 create mode 100644 progs/lib/hbc/ListUtil.hs
 create mode 100644 progs/lib/hbc/ListUtil.hu
 create mode 100644 progs/lib/hbc/Maybe.hs
 create mode 100644 progs/lib/hbc/Maybe.hu
 create mode 100644 progs/lib/hbc/Miranda.hs
 create mode 100644 progs/lib/hbc/Miranda.hu
 create mode 100644 progs/lib/hbc/Option.hs
 create mode 100644 progs/lib/hbc/Option.hu
 create mode 100644 progs/lib/hbc/Pretty.hs
 create mode 100644 progs/lib/hbc/Printf.hs
 create mode 100644 progs/lib/hbc/Printf.hu
 create mode 100644 progs/lib/hbc/QSort.hs
 create mode 100644 progs/lib/hbc/QSort.hu
 create mode 100644 progs/lib/hbc/README
 create mode 100644 progs/lib/hbc/Random.hs
 create mode 100644 progs/lib/hbc/Random.hu
 create mode 100644 progs/lib/hbc/Time.hs
 create mode 100644 progs/lib/hbc/Time.hu

(limited to 'progs/lib/hbc')

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
-- 
cgit v1.2.3