src/Tools/Metis/src/Sharing.sml

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/Metis/src/Sharing.sml	Mon Sep 13 21:09:43 2010 +0200
@@ -0,0 +1,158 @@
+(* ========================================================================= *)
+(* PRESERVING SHARING OF ML VALUES                                           *)
+(* Copyright (c) 2005-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
+(* ========================================================================= *)
+
+structure Sharing :> Sharing =
+struct
+
+infix ==
+
+val op== = Portable.pointerEqual;
+
+(* ------------------------------------------------------------------------- *)
+(* Option operations.                                                        *)
+(* ------------------------------------------------------------------------- *)
+
+fun mapOption f xo =
+    case xo of
+      SOME x =>
+      let
+        val y = f x
+      in
+        if x == y then xo else SOME y
+      end
+    | NONE => xo;
+
+fun mapsOption f xo acc =
+    case xo of
+      SOME x =>
+      let
+        val (y,acc) = f x acc
+      in
+        if x == y then (xo,acc) else (SOME y, acc)
+      end
+    | NONE => (xo,acc);
+
+(* ------------------------------------------------------------------------- *)
+(* List operations.                                                          *)
+(* ------------------------------------------------------------------------- *)
+
+fun map f =
+    let
+      fun m ys ys_xs xs =
+          case xs of
+            [] => List.revAppend ys_xs
+          | x :: xs =>
+            let
+              val y = f x
+              val ys = y :: ys
+              val ys_xs = if x == y then ys_xs else (ys,xs)
+            in
+              m ys ys_xs xs
+            end
+    in
+      fn xs => m [] ([],xs) xs
+    end;
+
+fun maps f =
+    let
+      fun m acc ys ys_xs xs =
+          case xs of
+            [] => (List.revAppend ys_xs, acc)
+          | x :: xs =>
+            let
+              val (y,acc) = f x acc
+              val ys = y :: ys
+              val ys_xs = if x == y then ys_xs else (ys,xs)
+            in
+              m acc ys ys_xs xs
+            end
+    in
+      fn xs => fn acc => m acc [] ([],xs) xs
+    end;
+
+local
+  fun revTails acc xs =
+      case xs of
+        [] => acc
+      | x :: xs' => revTails ((x,xs) :: acc) xs';
+in
+  fun revMap f =
+      let
+        fun m ys same xxss =
+            case xxss of
+              [] => ys
+            | (x,xs) :: xxss =>
+              let
+                val y = f x
+                val same = same andalso x == y
+                val ys = if same then xs else y :: ys
+              in
+                m ys same xxss
+              end
+      in
+        fn xs => m [] true (revTails [] xs)
+      end;
+
+  fun revMaps f =
+      let
+        fun m acc ys same xxss =
+            case xxss of
+              [] => (ys,acc)
+            | (x,xs) :: xxss =>
+              let
+                val (y,acc) = f x acc
+                val same = same andalso x == y
+                val ys = if same then xs else y :: ys
+              in
+                m acc ys same xxss
+              end
+      in
+        fn xs => fn acc => m acc [] true (revTails [] xs)
+      end;
+end;
+
+fun updateNth (n,x) l =
+    let
+      val (a,b) = Useful.revDivide l n
+    in
+      case b of
+        [] => raise Subscript
+      | h :: t => if x == h then l else List.revAppend (a, x :: t)
+    end;
+
+fun setify l =
+    let
+      val l' = Useful.setify l
+    in
+      if length l' = length l then l else l'
+    end;
+
+(* ------------------------------------------------------------------------- *)
+(* Function caching.                                                         *)
+(* ------------------------------------------------------------------------- *)
+
+fun cache cmp f =
+    let
+      val cache = ref (Map.new cmp)
+    in
+      fn a =>
+         case Map.peek (!cache) a of
+           SOME b => b
+         | NONE =>
+           let
+             val b = f a
+             val () = cache := Map.insert (!cache) (a,b)
+           in
+             b
+           end
+    end;
+
+(* ------------------------------------------------------------------------- *)
+(* Hash consing.                                                             *)
+(* ------------------------------------------------------------------------- *)
+
+fun hashCons cmp = cache cmp Useful.I;
+
+end