1 (* Copyright (C
) 1999-2006 Henry Cejtin
, Matthew Fluet
, Suresh
2 * Jagannathan
, and Stephen Weeks
.
4 * MLton is released under a BSD
-style license
.
5 * See the file MLton
-LICENSE for details
.
18 datatype t
= T
of {compare
: Rep
.t
* Rep
.t
-> Relation
.t
,
19 contains
: Rep
.t
-> bool,
21 toString
: Rep
.t
-> string}
26 datatype t
= T
of {domain
: Domain
.t
,
34 fun contains (T
{contains
, ...}, Value
.T
{rep
= r
, ...}) = contains r
36 fun new
{compare
: 'a
* 'a
-> Relation
.t
,
38 toString
: 'a
-> string}: t
* ('a
-> Value
.t
) =
41 val contains
= fn E _
=> true | _
=> false
42 val toString
= fn E x
=> toString x
43 | _
=> Error
.bug
"RDB.Domain.new.toString"
45 fn (E x
, E y
) => compare (x
, y
)
46 | _
=> Error
.bug
"RDB.Domain.new.compare"
47 val d
= T
{compare
= compare
,
51 fun make (a
: 'a
): Value
.t
= Value
.T
{domain
= d
, rep
= E a
}
55 val (bool, boolV
) = new
{compare
= Bool.compare
,
57 toString
= Bool.toString
}
59 val (int, intV
) = new
{compare
= Int.compare
,
61 toString
= Int.toString
}
63 val (real, realV
) = new
{compare
= Real.compare
,
66 fn r
=> Real.format (r
, Real.Format
.fix (SOME
1))}
69 val (string, stringV
) = new
{compare
= String.compare
,
71 toString
= String.toString
}
87 fun unary
f (T
{domain
= Domain
.T d
, rep
= r
, ...}) = f d r
89 val toString
= unary #toString
92 fun justification (T
{domain
= Domain
.T
{just
, ...}, ...}) = just
95 fun binary
f (T
{domain
= Domain
.T d
, rep
= r
, ...}, T
{rep
= r
', ...}) =
98 val compare
= binary #compare
101 val {<, <=, equals
, >=, >, ...} = Relation
.compare compare
104 structure Attribute
=
113 datatype t
= T
of (Attribute
.t
* Domain
.t
) list
115 fun degree (T l
) = List.length l
118 case List.peeki (l
, fn (_
, (a
', _
)) => Attribute
.equals (a
, a
')) of
119 NONE
=> Error
.bug
"RDB.Heading.info"
120 |
SOME (i
, (_
, d
)) => (i
, d
)
122 val position
= #
1 o info
125 datatype t
= T
of {heading
: Heading
.t
,
126 body
: Value
.t list list ref
}
128 fun add (T
{heading
= Heading
.T attrs
, body
, ...}, r
) =
131 List.fold (rev attrs
, [], fn ((a
, d
), ac
) =>
132 case List.peek (r
, fn (a
', _
) => Attribute
.equals (a
, a
')) of
133 NONE
=> Error
.bug
"RDB.add"
135 if Domain
.contains (d
, v
)
137 else Error
.bug
"RDB.add"))
139 fun cardinality (T
{body
, ...}) = List.length (!body
)
141 fun degree (T
{heading
, ...}) = Heading
.degree heading
143 fun new
{heading
} = T
{heading
= Heading
.T heading
,
146 fun project (T
{heading
, body
, ...}, a
: Attribute
.t
): Value
.t list
=
147 let val n
= Heading
.position (heading
, a
)
148 in List.fold (!body
, [], fn (vs
, ac
) =>
149 List.insert (vs
, List.nth (vs
, n
), Value
.<=))
152 fun outputTable (t
, out
) =
154 val print
= Out
.outputc out
156 List.foreach (t
, fn ss
=>
161 ; List.foreach (ss
, fn s
=>
162 (print
" "; print s
)))
166 fun printTable
{rdb
as T
{body
, heading
, ...}, row
, col
, entry
, out
}: unit
=
170 val rows
= project (rdb
, row
)
171 val cols
= project (rdb
, col
)
172 val nr
= Heading
.position (heading
, row
)
173 val nc
= Heading
.position (heading
, col
)
174 val ne
= Heading
.position (heading
, entry
)
176 ("" :: List.map (cols
, Value
.toString
)) ::
180 (rev rows
, [], fn (r
, ac
) =>
184 (cols
, [], fn (c
, ac
) =>
189 Value
.equals (r
, List.nth (t
, nr
))
190 andalso Value
.equals (c
, List.nth (t
, nc
))))
193 | SOME t
=> Value
.toString (List.nth (t
, ne
))
196 in (Value
.toString r
:: row
) :: ac
200 (Value
.justification (hd rows
)
201 :: List.map (cols
, Value
.justification
))
202 val t
= Justify
.table
{columnHeads
= NONE
, justs
= justs
, rows
= table
}
203 in outputTable (t
, out
)
206 fun printTable
' {rdb
as T
{body
, heading
= Heading
.T ads
, ...},
207 cols
, sortBy
, out
}: unit
=
209 val is
= List.revMap (cols
, fn a
=>
210 valOf (List.index (ads
, fn (a
', _
) =>
211 Attribute
.equals (a
, a
'))))
213 List.revMap (!body
, fn r
=>
214 let val a
= Array
.fromList r
215 in List.revMap (is
, fn i
=> Array
.sub (a
, i
))
217 val justs
= List.map (hd rows
, Value
.justification
)
218 val i
= valOf (List.index (cols
, fn a
=> Attribute
.equals (a
, sortBy
)))
220 QuickSort
.sortList (rows
, fn (r
, r
') =>
221 Value
.<= (List.nth (r
, i
), List.nth (r
', i
)))
223 List.map (cols
, Attribute
.toString
)
224 :: List.map (rows
, fn r
=> List.map (r
, Value
.toString
))
225 val t
= Justify
.table
{columnHeads
= NONE
,
228 in outputTable (t
, out
)