Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/trunk/benchmarks/programs/tsp/tsp.sml
ViewVC logotype

View of /sml/trunk/benchmarks/programs/tsp/tsp.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 193 - (download) (annotate)
Fri Nov 20 17:43:59 1998 UTC (22 years, 6 months ago) by monnier
File size: 5427 byte(s)
Initial revision
(* tsp.sml
 *
 * COPYRIGHT (c) 1994 AT&T Bell Laboratories.
 *)

structure TSP : sig

    val tsp : (Tree.tree * int) -> Tree.tree

  end = struct

    structure T = Tree

    fun setPrev (T.ND{prev, ...}, x) = prev := x
    fun setNext (T.ND{next, ...}, x) = next := x
    fun link (a as T.ND{next, ...}, b as T.ND{prev, ...}) = (
	  next := b; prev := a)

    fun sameNd (T.ND{next, ...}, T.ND{next=next', ...}) = (next = next')
      | sameNd (T.NULL, T.NULL) = true
      | sameNd _ = false

  (* Find Euclidean distance from a to b *)
    fun distance (T.ND{x=ax, y=ay, ...}, T.ND{x=bx, y=by, ...}) =
	  Math.sqrt(((ax-bx)*(ax-bx)+(ay-by)*(ay-by)))
      | distance _ = raise Fail "distance"

  (* sling tree nodes into a list -- requires root to be tail of list, and
   * only fills in next field, not prev.
   *)
    fun makeList T.NULL = T.NULL
      | makeList (t as T.ND{left, right, next = t_next, ...}) = let
	  val retVal = (case (makeList left, makeList right)
		 of (T.NULL, T.NULL) => t
		  | (l as T.ND{...}, T.NULL) => (setNext(left, t); l)
		  | (T.NULL, r as T.ND{...}) => (setNext(right, t); r)
		  | (l as T.ND{...}, r as T.ND{...}) => (
		      setNext(right, t); setNext(left, r); l)
		(* end case *))
	  in
	    t_next := T.NULL;
	    retVal
	  end

  (* reverse orientation of list *)
    fun reverse T.NULL = ()
      | reverse (t as T.ND{next, prev, ...}) = let
	  fun rev (_, T.NULL) = ()
	    | rev (back, tmp as T.ND{prev, next, ...}) = let
		val tmp' = !next
		in
		  next := back;  setPrev(back, tmp);
		  rev (tmp, tmp')
		end
	  in
	    setNext (!prev, T.NULL);
	    prev := T.NULL;
	    rev (t, !next)
	  end

  (* Use closest-point heuristic from Cormen Leiserson and Rivest *)
    fun conquer (T.NULL) = T.NULL
      | conquer t = let
	  val (cycle as T.ND{next=cycle_next, prev=cycle_prev, ...}) = makeList t
	  fun loop (T.NULL) = ()
	    | loop (t as T.ND{next=ref doNext, prev, ...}) =
		let
		fun findMinDist (min, minDist, tmp as T.ND{next, ...}) =
		      if (sameNd(cycle, tmp))
			then min
			else let
			  val test = distance(t, tmp)
			  in
			    if (test < minDist)
			      then findMinDist (tmp, test, !next)
			      else findMinDist (min, minDist, !next)
			  end
		val (min as T.ND{next=ref min_next, prev=ref min_prev, ...}) =
			findMinDist (cycle, distance(t, cycle), !cycle_next)
		val minToNext = distance(min, min_next)
		val minToPrev = distance(min, min_prev)
		val tToNext = distance(t, min_next)
		val tToPrev = distance(t, min_prev)
		in
		  if ((tToPrev - minToPrev) < (tToNext - minToNext))
		    then ( (* insert between min and min_prev *)
		      link (min_prev, t);
		      link (t, min))
		    else (
		      link (min, t);
		      link (t, min_next));
		  loop doNext
		end
	  val t' = !cycle_next
	  in
	  (* Create initial cycle *)
	    cycle_next := cycle;  cycle_prev := cycle;
	    loop t';
	    cycle
	  end

  (* Merge two cycles as per Karp *)
    fun merge (a as T.ND{next, ...}, b, t) = let
	  fun locateCycle (start as T.ND{next, ...}) = let
		fun findMin (min, minDist, tmp as T.ND{next, ...}) =
		      if (sameNd(start, tmp))
			then (min, minDist)
			else let val test = distance(t, tmp)
			  in
			    if (test < minDist)
			      then findMin (tmp, test, !next)
			      else findMin (min, minDist, !next)
			  end
		val (min as T.ND{next=ref next', prev=ref prev', ...}, minDist) =
			findMin (start, distance(t, start), !next)
		val minToNext = distance(min, next')
		val minToPrev = distance(min, prev')
		val tToNext = distance(t, next')
		val tToPrev = distance(t, prev')
		in
		  if ((tToPrev - minToPrev) < (tToNext - minToNext))
		  (* would insert between min and prev *)
		    then (prev', tToPrev, min, minDist)
		  (* would insert between min and next *)
		    else (min, minDist, next', tToNext)
		end
	(* Compute location for first cycle *)
	  val (p1, tToP1, n1, tToN1) = locateCycle a
	(* compute location for second cycle *)
	  val (p2, tToP2, n2, tToN2) = locateCycle b
	(* Now we have 4 choices to complete:
	 *   1:t,p1 t,p2 n1,n2
	 *   2:t,p1 t,n2 n1,p2
	 *   3:t,n1 t,p2 p1,n2
	 *   4:t,n1 t,n2 p1,p2
	 *)
	  val n1ToN2 = distance(n1, n2)
	  val n1ToP2 = distance(n1, p2)
	  val p1ToN2 = distance(p1, n2)
	  val p1ToP2 = distance(p1, p2)
	  fun choose (testChoice, test, choice, minDist) =
		if (test < minDist) then (testChoice, test) else (choice, minDist)
	  val (choice, minDist) = (1, tToP1+tToP2+n1ToN2)
	  val (choice, minDist) = choose(2, tToP1+tToN2+n1ToP2, choice, minDist)
	  val (choice, minDist) = choose(3, tToN1+tToP2+p1ToN2, choice, minDist)
	  val (choice, minDist) = choose(4, tToN1+tToN2+p1ToP2, choice, minDist)
	  in
	    case choice
	     of 1 => (	(* 1:p1,t t,p2 n2,n1 -- reverse 2! *)
		  reverse n2;
		  link (p1, t);
		  link (t, p2);
		  link (n2, n1))
	      | 2 => (	(* 2:p1,t t,n2 p2,n1 -- OK *)
		  link (p1, t);
		  link (t, n2);
		  link (p2, n1))
	      | 3 => (	(* 3:p2,t t,n1 p1,n2 -- OK *)
		  link (p2, t);
		  link (t, n1);
		  link (p1, n2))
	      | 4 => (	(* 4:n1,t t,n2 p2,p1 -- reverse 1! *)
		  reverse n1;
		  link (n1, t);
		  link (t, n2);
		  link (p2, p1))
	    (* end case *);
	    t
	  end (* merge *)

  (* Compute TSP for the tree t -- use conquer for problems <= sz * *)
    fun tsp (t as T.ND{left, right, sz=sz', ...}, sz) =
	  if (sz' <= sz)
	    then conquer t
	    else merge (tsp(left, sz), tsp(right, sz), t)
      | tsp (T.NULL, _) = T.NULL

  end;


root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0