Mini Project

Brian M. Lewis

Math 213 - Math with Mathematica
Due Thursday, November 5, 2009
This file calculates the shortest path between any two places on QC campus.

<<Combinatorica`

(* First thing I have to do is load the combinatorica library. The second part was creating a list of all the coordinates for my points.*)

Coordlist = {{0,0},{2,9},{2,13},{2,15},{2,21},{2,23},
{3,13},{3,15},{3,18},{3,20},{3,24},
{5,6},{5,8},{5,14},{5,20},{5,24},
{6,16},{6,21},{7,8},{7,10},{7,12},{7,15},
{8,8},{9,5},{10,7},{10,10},{10,12},{10,13},{10,17},{10,21},
{11,7},{11,12},{11,20},{12,0},{12,8},{12,12},{12,15},{12,18},{12,24},
{13,5},{13,7},{14,10},{14,13},{15,6},{15,7},{15,12},{16,15},{16,16},{16,19},
{17,5},{17,12},{17,14},{17,21},{18,0},{18,11},{18,21},{18,24},{19,6},{19,10},{26,0}};

(* I sorted the list in a way that each vertex is arranged from 1-60 from top left to bottom right*)

cl=Reverse[Sort[Coordlist,#1[[2]]<#2[[2]]&]]

cl={{3,24},{5,24},{12,24},{18,24},{2,23},{2,21},{6,21},{10,21},{17,21},{18,21},{3,20},{5,20},{11,20},{16,19},{3,18},{12,18},{10,17},{6,16},{16,16},{2,15},{3,15},{7,15},{12,15},{16,15},{5,14},{17,14},{2,13},{3,13},{10,13},{14,13},{7,12},{10,12},{11,12},{12,12},{15,12},{17,12},{18,11},{7,10},{10,10},{14,10},{19,10},{2,9},{5,8},{7,8},{8,8},{12,8},{10,7},{11,7},{13,7},{15,7},{5,6},{15,6},{19,6},{9,5},{13,5},{17,5},{0,0},{12,0},{18,0},{26,0}}

(*below i realized I was missing a vertex so I added a vertex at coordinates {15,21} and it is labeled 61*)

cl={{3,24},{5,24},{12,24},{18,24},{2,23},{2,21},{6,21},{10,21},{17,21},{18,21},{3,20},{5,20},{11,20},{16,19},{3,18},{12,18},{10,17},{6,16},{16,16},{2,15},{3,15},{7,15},{12,15},{16,15},{5,14},{17,14},{2,13},{3,13},{10,13},{14,13},{7,12},{10,12},{11,12},{12,12},{15,12},{17,12},{18,11},{7,10},{10,10},{14,10},{19,10},{2,9},{5,8},{7,8},{8,8},{12,8},{10,7},{11,7},{13,7},{15,7},{5,6},{15,6},{19,6},{9,5},{13,5},{17,5},{0,0},{12,0},{18,0},{26,0},{15,21}}

qc = AddVertices[EmptyGraph[0],cl]

(* Here is my graph points without any lines yet*)

ShowLabeledGraph[qc]

(*after this I had to add the edges, i have lots of groups for edges*)

SB = {1,2,5,6,7,11,12};

sbedges ={{1,2},{1,5},{1,6},{1,7},{1,11},{1,12},
{2,5},{2,6},{2,7},{2,11},{2,12},
{5,6},{5,7},{5,11},{5,12},
{6,7},{6,11},{6,12},{7,11},{7,12},{11,12}};

RE={15,18,21,25};

reedges = {{15,18},{15,21},{15,25},
{18,21},{18,25},{21,25}};

HH={21,25,28};

hhedges = {{21,28},{25,28}};

JH={45,47,54};

jhedges = {{45,47},{45,54},{47,54}};

KY={48,46,49,50,52,55};

KY=Sort[KY]

kyedges={{46,48},{46,49},{46,50},{46,52},{46,55},
{48,49},{48,50},{48,52},{48,52},{48,55},
{49,50},{49,52},{49,55},
{50,52},{50,55},
{52,55}};

KP={30,34,35,40};
kpedges = {{30,34},{30,35},{30,40},{34,35},{34,40},{35,40}};

PH={16,17,23,29};

phedges={{16,17},{16,23},{16,29},{17,23},{17,29},{23,29}};

RO={3,8,13,61};

roedges={{3,8},{3,13},{3,61},{8,13},{8,61},{13,61}};

DH={26,36,37};

dhedges={{26,36},{26,37},{36,37}};

(*Step by step, I'm creating this graph/map of QC, the complete graphs below represent some of the buildings on campus with multiple entrances and exits. The Idea is that if you are inside the building u should be able to leave through any exit. I used the AddEdges function to add the above edges, I removed the lines of code because I did not want to accidentally mess up the graph if I reevaluated the notebook, this is very tedious*)

paths = {{2,3},{3,4},{4,10},{10,9},{9,14},{10,14},{13,16},{6,20},{11,15},{20,21},{27,28},{18,22},{28,31},{27,42},{42,43},{42,51},{43,44},{7,18},{7,22},{7,8},{7,17},{8,17},{17,22},{22,29},{22,31},{31,32},{31,39},{31,38},{44,39},{38,44},{44,45}}

alledges = Union[paths,sbedges,reedges,hhedges, jhedges, kyedges, kpedges, phedges, roedges, dhedges]

qc1=AddEdges[qc,alledges]

moreedges = {{51,54},{54,57},{57,58},{58,59},{59,60},{59,56},{59,52},{40,46},{40,49},{40,50},{53,41},{41,37},{4,61},{61,14},{14,16},{20,27},{23,24},{23,26},{24,26},{19,24},{53,56},{53,50},{29,32},{32,33},{33,34},{58,55},{54,55},{33,39},{39,48}};

qc1=AddEdges[qc1,moreedges]

(* Finally all the edges I need are there*)

ShowLabeledGraph[qc1]

(*below is a test of the Manipulate function I will be needing*)

Manipulate[ShortestPath[qc1,u,v],{u,1,61,1},{v,1,61,1}]

ShowGraph[SetGraphOptions[qc1,{1,7,22,31,39,48,52,59,60,VertexColor->Red}]]

ShowGraph[qc1]

nobrack[{x__}]:=x

edges[x__]:=Module[{n=Length[x],i=1,g={}},While[i<n,g=Append[g,x[[{i,i+1}]]];i=i+1];g]

edges[{1,7,22,31,39,48,52,59,60}]

(* The above edges and nobrack functions I created because I was having trouble with the format of the outputs. nobrack simply removes the curly braces from the list. ShortestPath outputs a list of vertices which are single numbers, whereas edges are pairs so the edges function takes the output from shortestpath and converts it to a list of edges*)

ShowGraph[SetGraphOptions[qc1,{{nobrack[edges[ShortestPath[qc1,1,60]]],EdgeColor->Red},{nobrack[ShortestPath[qc1,1,60]],VertexColor->Red}}]]

The Map without stored values

Manipulate[ShowGraph[SetGraphOptions[qc1,
{{nobrack[edges[ShortestPath[qc1,start,end]]],EdgeColor->Red},
{nobrack[ShortestPath[qc1,start,end]],VertexColor->Red}}]],{start,1,61,1},{end,1,61,1}]

Map with store path values.

shortpaths[i_,j_]:=shortpaths[i,j]=ShortestPath[qc1,i,j]

Table[shortpaths[i,j],{i,1,61},{j,1,61}];

When the above line is evaluated it will calculate the shortest path for every possibility of paths and save the values so that it isn't necessary to calculate the path each time.

Timing[ShortestPath[qc1,5,60]]
Timing[shortpaths[5,60]]

(* Above is a test of the timing to see if my new function is truly faster *)

Manipulate[ShowGraph[SetGraphOptions[qc1,
{{nobrack[edges[shortpaths[start,end]]],EdgeColor->Red},
{nobrack[shortpaths[start,end]],VertexColor->Red}}]],Button["Swap Values",{start,end}={end,start}],{start,1,61,1},{end,1,61,1}]

(* Added a swap values button to show that some paths are inconsistent i.e. (10,48),(55,15)*)

Room for improvement

An option to choose indoor, outdoor routes.

Labeled Buildings on graph for better reference

Include all buildings and paths

Include image of qc map