; load "Int";
; load "CommandLine";

(* Aufgabe 10.1 *)

(*
sig
  type set = int list
  val 'a empty : 'a list
  val 'a insert : 'a * 'a list -> 'a list
  val ''a member : ''a * ''a list -> bool 
end
*)

(*
sig
  type set
  val empty : set
  val insert : string * set -> set
  val member : string * set -> bool
end
*)

(* Auf Bäumen ist keine Gleichheit definiert. *)

(* Aufgabe 10.2 *)

datatype color = R | B
datatype ctree = E | N of color * ctree * int * ctree

fun listA' E            ys = ys
  | listA'(N(_,a,x,b))  ys = listA' a (x::listA' b ys)

fun listA t = listA' t nil

fun listD' E            ys = ys
  | listD'(N(_,a,x,b))  ys = listD' b (x::listD' a ys)

fun listD t = listD' t nil

fun ordered (x::y::zs) = x<y andalso ordered(y::zs)
  | ordered     _      = true

fun sb b = ordered(listA b)

exception NotRB

fun forward (m,n) = if m=n then m else raise NotRB

fun black (N(R,_,_,_)) = raise NotRB
  | black      _       = ()

fun rb E            = 1
  | rb (N(B,a,_,b)) = 1 + forward(rb a, rb b)
  | rb (N(R,a,_,b)) = (black a ; black b ; forward(rb a, rb b))    

fun redblack t = (rb t; sb t) handle NotRB => false

(* Aufgabe 10.3 *)

functor Set 
  (type elem
   val  compare : elem * elem -> order) 
  :>
  sig
    type set
    val empty  : set
    val insert : elem * set -> set
    val member : elem * set -> bool
  end
  =
  struct
    datatype color = R | B
    datatype set   = E | N of color * set * elem * set

    val empty = E

    fun member (y, E)          = false
      | member (y, N(_,a,x,b)) = case compare(y,x) of
                                   LESS    => member(y,a)
                                 | EQUAL   => true
                                 | GREATER => member(y,b)

    fun rotate (x,y,z,a,b,c,d) = N(R, N(B,a,x,b), y, N(B,c,z,d))

    fun rotateL (B, N(R,N(R,a,x,b),y,c), z, d) = rotate(x,y,z,a,b,c,d)
      | rotateL (B, N(R,a,x,N(R,b,y,c)), z, d) = rotate(x,y,z,a,b,c,d)
      | rotateL         body                   = N body

    fun rotateR (B, a, x, N(R,b,y,N(R,c,z,d))) = rotate(x,y,z,a,b,c,d)
      | rotateR (B, a, x, N(R,N(R,b,y,c),z,d)) = rotate(x,y,z,a,b,c,d)
      | rotateR         body                   = N body

    fun insert' (y, E)              = N(R,E,y,E)
      | insert' (y, N(color,a,x,b)) = 
        case compare(y,x) of
          LESS    => rotateL(color, insert'(y,a), x, b)
        | EQUAL   => N(color,a,y,b)
        | GREATER => rotateR(color, a, x, insert'(y,b))

    fun insert (y,a) = case insert'(y,a) of
                         N(_,a,x,b) => N(B,a,x,b)
                       | E          => E
  end

(* Aufgabe 10.4 *)

functor Map 
  (type key
   val  compare : key * key -> order) 
  :>
  sig
    type 'a map
    val empty  : 'a map
    val insert : key * 'a * 'a map -> 'a map
    val lookup : key * 'a map -> 'a option
  end
  =
  struct
    datatype color  = R | B
    datatype 'a map = E | N of color * 'a map * (key * 'a) * 'a map

    val empty = E

    fun compare' ((k,_),(k',_)) = compare(k,k')

    fun lookup (k, E)                = NONE
      | lookup (k, N(_,a,(k',e'),b)) = case compare(k, k') of
                                       LESS    => lookup(k,a)
                                     | EQUAL   => SOME e'
                                     | GREATER => lookup(k,b)

    fun rotate (x,y,z,a,b,c,d) = N(R, N(B,a,x,b), y, N(B,c,z,d))

    fun rotateL (B, N(R,N(R,a,x,b),y,c), z, d) = rotate(x,y,z,a,b,c,d)
      | rotateL (B, N(R,a,x,N(R,b,y,c)), z, d) = rotate(x,y,z,a,b,c,d)
      | rotateL         body                   = N body

    fun rotateR (B, a, x, N(R,b,y,N(R,c,z,d))) = rotate(x,y,z,a,b,c,d)
      | rotateR (B, a, x, N(R,N(R,b,y,c),z,d)) = rotate(x,y,z,a,b,c,d)
      | rotateR         body                   = N body

    fun insert' (y, E)              = N(R,E,y,E)
      | insert' (y, N(color,a,x,b)) = 
        case compare'(y,x) of
          LESS    => rotateL(color, insert'(y,a), x, b)
        | EQUAL   => N(color,a,y,b)
        | GREATER => rotateR(color, a, x, insert'(y,b))

    fun insert (k,e,a) = case insert'((k,e),a) of
                           N(_,a,x,b) => N(B,a,x,b)
                         | E          => E
  end

(* Aufgabe 10.5 *)

signature Bignat =
  sig
    eqtype bignat

    val fromString : string -> bignat
    val toString   : bignat -> string
    val add        : bignat * bignat -> bignat
    val sub        : bignat * bignat -> bignat        (* Domain *)
    val less       : bignat * bignat -> bool
    val mul        : bignat * bignat -> bignat
  end

structure Bignat :> Bignat =
  struct
    type bignat = int list  (* least significant digit first *)

    val Base = 10000  (* fromString expects Base = 10000 *)

    fun adj (d,xs) = if null xs andalso d=0 then [] else d::xs

    fun fromInt n = if n<1 then [] else n mod Base :: fromInt(n div Base)

    fun add'([],    br,    0)  = br
      | add'([],    br,    c)  = add'([c],br,0)
      | add'(ar,    [],    0)  = ar
      | add'(ar,    [],    c)  = add'(ar,[c],0)
      | add'(a::ar, b::br, c)  = 
        let
          val s      = a+b+c
          val (d,c') = if s < Base then (s,0) else (s-Base,1)
        in
          d :: add'(ar,br,c')
        end

    fun add(ar,br) = add'(ar,br,0)

    fun sub'(ar,    [],    0)  = ar
      | sub'([],    _ ,    _)  = raise Domain
      | sub'(ar,    [],    c)  = sub'(ar,[c],0)
      | sub'(a::ar, b::br, c)  = 
        let
          val s      = a-b-c
          val (d,c') = if s>=0 then (s, 0) else (s+Base, 1)
        in
          adj(d, sub'(ar,br,c'))
        end

    fun sub(ar,br) = sub'(ar,br,0)

    fun less (x,y) = (sub(x,y) ; false) handle Domain => true

    fun mul'([],    _, c) = fromInt c
      | mul'(_,     0, c) = fromInt c
      | mul'(a::ar, b, c) = let 
                              val s = a*b+c 
                            in 
                              s mod Base :: mul'(ar, b, s div Base)
                            end

    fun mul([], _    ) = []
      | mul(_,  []   ) = []
      | mul(ar, b::br) = add(mul'(ar,b,0), adj(0, mul(ar, br)))

    val ord0 = ord #"0"
    val ten  = fromInt 10

    fun charToBignat c = fromInt(ord c - ord0)

    fun fromString s = foldl (fn (c,n) => add(charToBignat c, mul(ten, n)))
                         nil (explode s)

    fun pad s = case size s of
                  1 => "000" ^ s
                | 2 => "00" ^ s
                | 3 => "0" ^ s
                | _ => s 

    fun toString'   nil   = "0"
      | toString' (s::ss) = s ^ foldr (fn (s,t) => pad s ^ t) "" ss

    fun toString x = toString'(map Int.toString (rev x))
  end

open Bignat

val one = fromString "1"
val two = fromString "2"

fun fac' n = if less(n,two) then one else mul(n, fac'(sub(n,one)))

fun fac s = toString(fac'(fromString s))

val _ = case CommandLine.arguments() of
          [s] => print (fac s ^ "\n")
        |  _  => print "Need a number\n"

(*
- fac "1000";
> val it =
    "402387260077093773543702433923003985719374864210714632543799910429938512398
62902059204420848696940480047998861019719605863166687299480855890132382966994459
09974245040870737599188236277271887325197795059509952761208749754624970436014182
78094646496291056393887437886487337119181045825783647849977012476632889835955735
43251318532395846307555740911426241747434934755342864657661166779739666882029120
73791438537195882498081268678383745597317461360853795345242215865932019280908782
97308431392844403281231558611036976801357304216168747609675871348312025478589320
76716913244842623613141250878020800026168315102734182797770478463586817016436502
41536913982812648102130927612448963599287051149649754199093422215668325720808213
33186116811553615836546984046708975602900950537616475847728421889679646244945160
76535340819890138544248798495995331910172335555660213945039973628075013783761530
71277619268490343526252000158885351473316117021039681759215109077880193931781141
94545257223865541461062892187960223838971476088506276862967146674697562911234082
43920816015378088989396451826324367161676217916890977991190375403127462228998800
51954444142820121873617459926429565817466283029555702990243241531816172104658320
36786906117260158783520751516284225540265170483304226143974286933061690897968482
59012545832716822645806652676995865268227280707578139185817888965220816434834482
59932660433676601769996128318607883861502794659551311565520360939881806121385586
00301435694527224206344631797460594682573103790084024432438465657245014402821885
25247093519062092902313649327349756551395872055965422874977401141334696271542284
58623773875382304838656889764619273838149001407673104466402598994902222217659043
39901886018566526485061799702356193897017860040811889729918311021171229845901641
92106888438712185564612496079872290851929681937238864261483965738229112312502418
66493531439701374285319266498753372189406942814341185201580141233448280150513996
94290153483077644569099073152433278288269864602789864321139083506217095002597389
86355427719674282224875758676575234422020757363056949882508796892816275384886339
69099598262809561214509948717012445164612603790293091208890869420285106401821543
99457156805941872748998094254742173582401063677404595741785160829230135358081840
09699637252423056085590370062427124341690900415369010593398383577793941097002775
34720000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
0000000000000"
*)