(require (lib "graphics.ss" "graphics"))
(require (lib "draw.ss" "htdp"))
(require (lib "math.ss"))

;====================================================================================================

;Program Created by: Aqo Cyrale
;Development Started: 17.11.2008
;Finalized Version 1: 29.11.2008

(define -Ground 0)
(define -Wall 1)

;====================================================================================================

;          [ Basic Operations and Shortcuts ]

(define (wait time) (sleep-for-a-while (/ time 100)))   ;Delays the next action
(define (Toggle Boolean) (equal? Boolean #f))           ;Toggles a boolean
(define (++ int) (+ int 1)) (define (-- int) (- int 1)) ;Classic ++/-- Operation shortcut
(define (LR Item Ref) (list-ref Item Ref))              ;Listref writing shortcut
(define (VR V Ref) (vector-ref V Ref))                  ;Vector-ref writing shortcut
(define (VS V Ref New) (vector-set! V Ref New))         ;Vector-set writing shortcut
(define (RGB R G B) (make-rgb (/ R 255) (/ G 255) (/ B 255))) ;Returns a color

;Prints a text with variable parameters, uses "$" as Enter and "%" as parameter slot
(define (PrintLine Text v L?)
  (cond ((and L? (= (string-length Text) 0)) (newline))
        ((= (string-length Text) 0) (display ""))
        ((equal? (string-ref Text 0) #\%)
         (display (first v)) (PrintLine (substring Text 1) (rest v) L?))
        ((equal? (string-ref Text 0) #\$) (newline) (PrintLine (substring Text 1) v L?))
        (else (display (string-ref Text 0)) (PrintLine (substring Text 1) v L?))))

(define Print ;Prints a text, either with variables or just the base text
  (case-lambda [(Text . v) (PrintLine Text v #f)]))

(define Println ;Prints a text and jumps to the next line after printing
  (case-lambda [(Text . v) (PrintLine Text v #t)]))

;Returns whether an item is inside a list
(define (Inside Item List)
  (cond ((empty? List) #f)
        ((equal? Item (first List)) #t)
        (else (Inside Item (rest List)))))

;Returns a list without the first Item instance
(define (RFL Item List)
  (cond ((empty? List) '())
        ((equal? (first List) Item) (rest List))
        (else (cons (first List) (RFL Item (rest List))))))

;====================================================================================================

;          [ Special Section ]

(define -Speed (vector 0))
(define (SetSpeed X) (VS -Speed 0 X))
(define (Speed) (VR -Speed 0))

(define (GetCL Map) (LR Map 4)) (define (Build+CL Map)
  (SetMapSize (MSize Map)) (SetTerrainConst (MTerrain Map))
  (append Map (list (BuildChokeList (ReturnAllCorners (MTerrain Map))))))

(define (PaintClose Close)
  (cond ((not (empty? Close)) (PaintStep (first Close)) (PaintClose (rest Close)))))
(define (PaintStep Step) (PaintXYList (BuildLine (LR (Father Step) 0) (LR (Father Step) 1)
                         (LR (Child Step) 0) (LR (Child Step) 1)) -OutputPath (Speed)))

;====================================================================================================

;          [ Graphics Engine ]

(define WDim (vector 320 320)) ;Window Dimensions

(open-graphics) (define Window (open-viewport "Window" (VR WDim 0) (VR WDim 1))) ;Holds the viewport

      ;-----= Color Constants =-----------;
      (define Black      (RGB 000 000 000))
      (define White      (RGB 255 255 255))
      (define Red        (RGB 255 000 000))
      (define Green      (RGB 000 255 000))
      (define Blue       (RGB 000 000 255))

;Paints a rectangle on the display window
(define (PaintRect X Y XL YL Color) ((draw-solid-rectangle Window) (make-posn X Y) XL YL Color))

;Paints a cell on the map
(define (PaintCell X Y Color)
  (PaintRect (* X (VR MapConst 1)) (* Y (VR MapConst 1)) (VR MapConst 1) (VR MapConst 1) Color))

;Paints a cell line on the map
(define (PaintCellRect X1 Y1 X2 Y2 Color)
  (PaintRect (* X1 (VR MapConst 1)) (* Y1 (VR MapConst 1))
             (* (++ (- X2 X1)) (VR MapConst 1)) (* (++ (- Y2 Y1)) (VR MapConst 1)) Color))

;Like Paint Cell Rect, only that this will ignore ground tiles
(define (GroundTrim X1 Y1 X2 Y2 Type)
  (cond ((not (equal? Type -Ground))
         (PaintRect (* X1 (VR MapConst 1)) (* Y1 (VR MapConst 1))
         (* (++ (- X2 X1)) (VR MapConst 1)) (* (++ (- Y2 Y1)) (VR MapConst 1)) (TypeDB Type)))))

;Paints a list of terrain position XY lists either with a default color or an input color
(define PaintXYList (case-lambda [(XYList) (PaintXYList* XYList Cyan 0)]
                                 [(XYList Color) (PaintXYList* XYList Color 0)]
                                 [(XYList Color Speed) (PaintXYList* XYList Color Speed)]))
(define (PaintXYList* XYList Color Speed)
  (cond ((not (empty? XYList)) (PaintCell (LR (first XYList) 0) (LR (first XYList) 1) Color)
         (wait Speed) (PaintXYList* (rest XYList) Color Speed))))

;Simulates movement across a Step List
(define (WalkAcross SL Color Speed)
  (cond ((not (empty? SL))
         (WalkOver (reverse (BuildLine (LR (Child (first SL)) 0) (LR (Child (first SL)) 1)
         (LR (Father (first SL)) 0) (LR (Father (first SL)) 1))) Color Speed)
         (WalkAcross (rest SL) Color Speed))))

;Walks over an XYLine
(define (WalkOver XYLine Color Speed)
  (cond ((> (length XYLine) 1)
         (PaintCell (LR (second XYLine) 0) (LR (second XYLine) 1) Color)
         (PaintCell (LR (first XYLine) 0) (LR (first XYLine) 1) -GroundColor)
         (wait Speed) (WalkOver (rest XYLine) Color Speed))))

;Paints a list of terrain positions
(define (PaintCornerList CornerList)
  (cond ((not (empty? CornerList))
         (PaintCell (LR (first CornerList) 0) (LR (first CornerList) 1) Cyan)
         (PaintCornerList (rest CornerList)))))

;Colors the entire map in the Ground section color
(define (Clear) (PaintRect 0 0 (VR WDim 0) (VR WDim 1) (TypeDB -Ground)))

;====================================================================================================

;          [ Map Builder ]

(define MapConst (vector (VR WDim 0) 1)) ;MapConst holds: 1. MapSize, 2. Cell Dimensions

;Basic shortcuts for Map lists
(define (MSize Map) (LR Map 0))
(define (MTerrain Map) (LR Map 1))
(define (MStart Map) (LR Map 2))
(define (MEnd Map) (LR Map 3))

;Holds the terrain of the map that's currently being searched on
(define MapTerrain (vector '((0))))
(define S-E (vector '(0 0) '(0 0)))

;Basic shortcuts for the Terrain holder
(define (SetTerrainConst Terrain) (VS MapTerrain 0 Terrain))
(define (GetTerrain) (VR MapTerrain 0))

(define (SetStartConst Start) (VS S-E 0 Start)) (define (GetStart) (VR S-E 0))
(define (SetEndConst End) (VS S-E 1 End)) (define (GetEnd) (VR S-E 1))

;Sets the map size
(define (SetMapSize NewMapSize)
  (VS MapConst 0 NewMapSize) (VS MapConst 1 (/ (VR WDim 0) NewMapSize)))

;Returns the map size
(define (GetMapSize) (VR MapConst 0))

;Returns a specific position in a 2D list, such as a Map's terrain
(define (Pos2D Terrain X Y) (LR (LR Terrain Y) X))

;Paints a map
(define (PaintMap Map)
  (SetMapSize (MSize Map)) (SetTerrainConst (MTerrain Map))
  (Clear) (DisplayHeightfield (MTerrain Map) 0)
  (PaintCell (LR (MStart Map) 0) (LR (MStart Map) 1) -StartColor)
  (PaintCell (LR (MEnd Map) 0) (LR (MEnd Map) 1) -EndColor))

;Paints a heightfield
(define (DisplayHeightfield HF Y)
  (DisplayHFLine (first HF) 0 Y)
  (cond ((> (length HF) 1) (DisplayHeightfield (rest HF) (++ Y)))))

;Paints a single heightfield row
(define (DisplayHFLine HFLine X Y)
  (DisplayXSet (rest HFLine) X X Y (first HFLine)))

;Handles painting a row in sets to run faster
(define (DisplayXSet HFLine X1 X2 Y Type)
  (cond ((empty? HFLine) (GroundTrim X1 Y X2 Y Type))
        ((equal? (first HFLine) Type) (DisplayXSet (rest HFLine) X1 (++ X2) Y Type))
        (else (GroundTrim X1 Y X2 Y Type) (DisplayHFLine HFLine (++ X2) Y))))

;Converts a cell type into a color
(define (TypeDB Cell)
  (cond ((equal? Cell -Ground) -GroundColor)
        ((equal? Cell -Wall) -WallColor)))

;====================================================================================================

;          [ Heightfield Handler ]

(define-struct HF (Type X1 Y1 X2 Y2))
(define (HF Type X1 Y1 X2 Y2) (make-HF Type X1 Y1 X2 Y2))

;Builds a list of Item in the length Size
(define (BuildList Size Item) (cond ((> Size 0) (cons Item (BuildList (-- Size) Item))) (else '())))

;Builds a map from a Hex list
(define (BuildMap Size Start End HexList)
  (SetMapSize Size) (list Size (HFList->Map (HexList->HFList HexList)) Start End))

;Converts a heightfield list into a map
(define (HFList->Map HFList)
  (AddHFsToMap (BuildList (VR MapConst 0) (BuildList (VR MapConst 0) -Ground)) HFList))

;Adds a heightfield list into a map
(define (AddHFsToMap Map HFList)
  (cond ((empty? HFList) Map)
        (else (AddHFsToMap (AddHFToMap Map (first HFList)) (rest HFList)))))

;Adds one heightfield into a map
(define (AddHFToMap Map HF)
  (HF++ Map (HF-Type HF) (min (HF-X1 HF) (HF-X2 HF)) (min (HF-Y1 HF) (HF-Y2 HF))
                         (max (HF-X1 HF) (HF-X2 HF)) (max (HF-Y1 HF) (HF-Y2 HF))))

;Builds a rectangle of Type into a map
(define (HF++ Map Type X1 Y1 X2 Y2)
  (cond ((< Y2 0) Map)
        ((> Y1 0) (cons (first Map) (HF++ (rest Map) Type X1 (-- Y1) X2 (-- Y2))))
        (else (cons (HFX++ (first Map) Type X1 X2) (HF++ (rest Map) Type X1 Y1 X2 (-- Y2))))))

;Builds a line of Type into a map row
(define (HFX++ MapRow Type X1 X2)
  (cond ((< X2 0) MapRow)
        ((> X1 0) (cons (first MapRow) (HFX++ (rest MapRow) Type (-- X1) (-- X2))))
        (else (cons (HexType Type) (HFX++ (rest MapRow) Type X1 (-- X2))))))

;Converts a hex list into a heightfield list
(define (HexList->HFList HexList)
  (cond ((empty? HexList) '())
        (else (cons (Hex->HF (first HexList)) (HexList->HFList (rest HexList))))))

;Converts a hex into a heightfield
(define (Hex->HF Hex)
  (make-HF (ModHex Hex 5 (SizeupHex (NumLen Hex)))
           (ModHex Hex 4 (SizeupHex (NumLen Hex)))
           (ModHex Hex 3 (SizeupHex (NumLen Hex)))
           (ModHex Hex 2 (SizeupHex (NumLen Hex)))
           (ModHex Hex 1 (SizeupHex (NumLen Hex)))))

;Returns the length of a number
(define (NumLen Int) (cond ((< Int 10) 1) (else (+ 1 (NumLen (/ Int 10))))))

;Detects what size the hex is of
(define (SizeupHex HexLength) (expt 10 (/ (- HexLength 1) 4)))

;Returns a specific part of the hex
(define (ModHex Hex Ref By)
  (cond ((> Ref 1) (ModHex (/ Hex By) (-- Ref) By))
        (else (modulo (floor Hex) By))))

;Converts a hex type data into a map heightfield type data
(define (HexType Type) (LR HexTypeSet Type))
(define HexTypeSet (list 0 -Wall -Ground))

;----------------------------------------------------------------------------------------------------

;          [ Map Editor ] -- UNFINISHED

(define (MapEditor) (ME-UpdateGFX '()))

(define (ME-UpdateGFX Map NewHex)
  (cond ((empty? NewGFX) (--iterate--))
        (else (--paint-- (first NewHex))
              (ME-UpdateGFX Map (rest NewHex)))))

;====================================================================================================

;          [ QO2* Search Algorithm ]

(define -CL (vector 0)) ;Current Choke List (CCL)
(define (CCL) (VR -CL 0)) (define (SetCCL To) (VS -CL 0 To)) ;Get and Set for CCL

(define-struct Step (Father Child J))
(define (Step Father Child J) (make-Step Father Child J))
(define (Child Step) (Step-Child Step))
(define (Father Step) (Step-Father Step))

(define-struct Pos (CH DE J))
(define (Pos CH DE J) (make-Pos CH DE J))

;Runs the QO2* search on a map, gets the Start and End from the Map
;You can override the Start and End of the Map by using QO2* directly
(define (Run Map) (PaintMap Map) (QO2* Map (MStart Map) (MEnd Map)))

;Initiates a QO2* algorithm
(define (QO2* Map Start End)
  (SetTerrainConst (MTerrain Map)) (SetStartConst Start) (SetEndConst End)
  (PreRunQO2* '() '() (MakeCL+S/E (ReturnAllCorners (GetTerrain)) Start End)))

;Makes a Choke List that includes Start and End as corners
(define (MakeCL+S/E CornerList Start End) (Print "Build Choke: ")
  (time (BuildChokeList (reverse (cons Start (cons End (reverse CornerList)))))))

;Triggers the QO2* by putting the first choke from CL into the left-to-check list called Open
(define (PreRunQO2* Open Close CL)
  (SetCCL CL) (time (RunQO2* (cons (Pos (first CL) (DTE (first CL)) 0) Open) Close '())))

;Grid A* - Full implementation of QO*
(define (RunQO2* Open Close Done)
  (cond ((empty? Open) (Print "Paint Path:  ")
         (time (PaintClose (reverse (Retrace Close (FindClosestChild Close (GetEnd)))))))
        ((EqualChokeXY? (Pos-CH (first Open)) (GetEnd)) (Print "Paint Path:  ")
         (time (PaintClose (reverse (Retrace Close)))))
        ((InsideDone? (first Open) Done) (RunQO2* (rest Open) Close Done))
        (else (RunQO2* (UpdateOpen (Pos-CH (first Open)) (Pos-J (first Open)) (rest Open))
                       (UpdateClose Close (Pos-CH (first Open)) (Pos-J (first Open)))
                       (AddDone (first Open) Done)))))

;Checks if a Pos's XY was already used before
(define (InsideDone? Pos Done)
  (cond ((empty? Done) #f)
        ((and (EqualChokeXY? (Pos-CH Pos) (first Done))) #t)
        (else (InsideDone? Pos (rest Done)))))

;Adds a new Pos XY+J into Done
(define (AddDone Pos Done)
  (cons (list (Choke-X (Pos-CH Pos)) (Choke-Y (Pos-CH Pos)) (Pos-J Pos)) Done))

;Returns the distance to End from a Choke
(define (DTE Cho)
  (sqrt (+ (expt (- (Choke-X Cho) (LR (GetEnd) 0)) 2) (expt (- (Choke-Y Cho) (LR (GetEnd) 1)) 2))))

;Returns the distance from X Y to Start
(define (DTS X Y)
  (sqrt (+ (expt (- X (LR (GetStart) 0)) 2) (expt (- Y (LR (GetStart) 1)) 2))))

;Returns true if a choke's X and Y properties are equal to an XY list
(define (EqualChokeXY? Cho XY)
  (cond ((and (equal? (Choke-X Cho) (LR XY 0))
              (equal? (Choke-Y Cho) (LR XY 1))) #t) (else #f)))

;Adds all possible paths from Open's first Choke into Open while maintaining Open organized
(define (UpdateOpen Cho *J Open)
  (AddNewPositions Open (Choke-Paths Cho) (list (Choke-X Cho) (Choke-Y Cho)) *J))

;Converts a path into a Choke from a ChokeList
(define (GetCCLChoke Pa CL)
  (cond ((and (equal? (Path-X Pa) (Choke-X (first CL)))
              (equal? (Path-Y Pa) (Choke-Y (first CL)))) (first CL))
        (else (GetCCLChoke Pa (rest CL)))))

;Handles adding all paths into Open
(define (AddNewPositions Open NewPaths *XY *J)
  (cond ((empty? NewPaths) Open)
        (else (AddNewPositions (PrioritizedAdd Open (first NewPaths) *XY *J)
                               (rest NewPaths) *XY *J))))

;Adds a single path into Open as a Pos
(define (PrioritizedAdd Open P *XY *J)
  (Priority Open (Pos (GetCCLChoke P (CCL)) (DTE (Choke (Path-X P) (Path-Y P) '()))
  (+ *J (PitaDistance (list (LR *XY 0) (LR *XY 1)) (list (Path-X P) (Path-Y P)))))))

;Puts a Pos into Open at the correct priority location
(define (Priority Open P)
  (cond ((empty? Open) (list P))
        ((HigherPriority? P (first Open)) (cons P Open))
        (else (cons (first Open) (Priority (rest Open) P)))))

;Returns True if the first Pos has a higher priority than the second one
(define (HigherPriority? Pos1 Pos2)
  (cond ((< (+ (Pos-DE Pos1) (Pos-J Pos1)) (+ (Pos-DE Pos2) (Pos-J Pos2))) #t) (else #f)))

;Adds all possible Steps created by moving from a Choke to its paths to Close
(define (UpdateClose Close Cho SJ)
  (Close++ Close (list (Choke-X Cho) (Choke-Y Cho)) (Choke-Paths Cho) SJ))

;Used by UpdateClose, goes over each path and adds a step per one
(define (Close++ Close *XY NewP SJ)
  (cond ((empty? NewP) Close)
        (else (cons (Step *XY (list (Path-X (first NewP)) (Path-Y (first NewP)))
              (+ SJ (PitaDistance (list (LR *XY 0) (LR *XY 1))
                    (list (Path-X (first NewP)) (Path-Y (first NewP))))))
                    (Close++ Close *XY (rest NewP) SJ)))))

;EXTENSION =====
(define (FindClosestChild StepList Target)
  (FCC-X StepList Target (GetMapSize) '(0 0)))

(define (FCC-X SL T Min RTRN)
  (cond ((empty? SL) RTRN)
        ((< (PitaDistance (Child (first SL)) T) Min)
         (FCC-X (rest SL) T (PitaDistance (Child (first SL)) T) (Child (first SL))))
        (else (FCC-X (rest SL) T Min RTRN))))

; ===== ===== =====

;Basic retracing function, converts Close into a path
(define (Retrace- Close End)
  (cond ((equal? (Child (first Close)) End)
         (SuperRetrace Close (Father (first Close))))
        (else (Retrace- (rest Close) End))))

;Retracing extension that allows a noncorrect end
(define Retrace (case-lambda [(Close) (Retrace- Close (GetEnd))]
                             [(Close End) (Retrace- Close End)]))

;Macro control for the retracer
(define (SuperRetrace Close Next)
  (cond ((empty? Close) (display "END!"))
        ((equal? (Father (first Close)) (GetStart))
         (list (first Close)))
        ((equal? (Father (first Close)) Next)
         (cons (first Close)
               (RunRetracer Close (Father (first Close)) (* (Step-J (first Close)) 20) 0)))
        (else (SuperRetrace (rest Close) Next))))

;Runs the smart retracer
(define (RunRetracer Close NewNext MinJ Pos)
  (cond ((= Pos (length Close))
         (SuperRetrace Close (Father (first Close))))
        ((and (equal? (Child (LR Close Pos)) NewNext)
              (< (Step-J (LR Close Pos)) MinJ))
         (RunRetracer (CutList Close Pos) NewNext (Step-J (LR Close Pos)) 0))
        (else (RunRetracer Close NewNext MinJ (++ Pos)))))

;Removes the first X items of a list
(define (CutList List HowMuch)
  (cond ((> HowMuch 0) (CutList (rest List) (-- HowMuch))) (else List)))

;----------------------------------------------------------------------------------------------------

;          [ Corner Finder v2.0 ]

;Finds all the corners in a map's Terrain
;Public Function: (ReturnAllCorners Terrain)

;Returns a list of all the corner XY locations on a map's terrain
;Note that the MapSize public propery has to be correct or else this won't work
(define (ReturnAllCorners Terrain) (FindCorners Terrain 0 0 '()))

;Finds all the corners on a terrain
(define (FindCorners Terrain X Y Corners)
  (cond ((= Y (GetMapSize)) Corners)
        ((= X (GetMapSize)) (FindCorners Terrain 0 (++ Y) Corners))
        (else (FindCorners Terrain (++ X) Y (AddCorners Terrain X Y Corners)))))

;Adds corners from a wall if possible and new
(define (AddCorners Terrain X Y Corners)
  (cond ((equal? (Pos2D Terrain X Y) -Ground) Corners)
        (else (AddNewLTL (GetCorners (OBCH Terrain X (-- Y)) (OBCH Terrain (++ X) Y)
              (OBCH Terrain X (++ Y)) (OBCH Terrain (-- X) Y) #t #t #t #t X Y) Corners))))

;Off-Board Corner Handler - returns a wall if the point is off the board
(define (OBCH Terrain X Y)
  (cond ((and (>= X 0) (>= Y 0) (< X (GetMapSize)) (< Y (GetMapSize))) (Pos2D Terrain X Y))
        (else -Wall)))

;Returns a list of all corners that go out of a wall section
(define (GetCorners P1 P2 P3 P4 O1 O2 O3 O4 X Y)
  (cond ((equal? P1 -Wall) (GetCorners -Ground P2 P3 P4 #f #f O3 O4 X Y))
        ((equal? P2 -Wall) (GetCorners P1 -Ground P3 P4 O1 #f #f O4 X Y))
        ((equal? P3 -Wall) (GetCorners P1 P2 -Ground P4 O1 O2 #f #f X Y))
        ((equal? P4 -Wall) (GetCorners P1 P2 P3 -Ground #f O2 O3 #f X Y))
        (else (CaseCorners O1 O2 O3 O4 X Y))))

;Used by GetCorners, translates the true/false data into actual corner lists
(define (CaseCorners TL TR BR BL X Y)
  (cond ((and TL (equal? (Pos2D (GetTerrain) (-- X) (-- Y)) -Ground))
         (cons (list (-- X) (-- Y)) (CaseCorners #f TR BR BL X Y)))
        ((and TR (equal? (Pos2D (GetTerrain) (++ X) (-- Y)) -Ground))
         (cons (list (++ X) (-- Y)) (CaseCorners TL #f BR BL X Y)))
        ((and BR (equal? (Pos2D (GetTerrain) (++ X) (++ Y)) -Ground))
         (cons (list (++ X) (++ Y)) (CaseCorners TL TR #f BL X Y)))
        ((and BL (equal? (Pos2D (GetTerrain) (-- X) (++ Y)) -Ground))
         (cons (list (-- X) (++ Y)) (CaseCorners TL TR BR #f X Y)))
        (else '())))

;Adds a new list into a list; only adds items from list1 if they're not inside list2
(define (AddNewLTL NewList List)
  (cond ((empty? NewList) List)
        ((Inside (first NewList) List) (AddNewLTL (rest NewList) List))
        (else (cons (first NewList) (AddNewLTL (rest NewList) List)))))

;----------------------------------------------------------------------------------------------------

;          [ Grid Developer ]

;Converts a list of corners into a list of chokes
;Public Function: (BuildChokeList CornerList)

(define-struct Choke (X Y Paths))       (define (Choke X Y Paths) (make-Choke X Y Paths))
(define-struct Path (X Y))              (define (Path X Y) (make-Path X Y))

;Converts a list of corners into a list of chokes
(define (BuildChokeList CornerList) (Corners->Chokes CornerList '() 0))

;Goes over a cornerlist, converting each corner in it into a choke
(define (Corners->Chokes CornerList ChokeList Pos)
  (cond ((= Pos (length CornerList)) ChokeList)
        (else (Corners->Chokes CornerList
              (AddChoke (LR CornerList Pos) CornerList ChokeList) (++ Pos)))))

;Adds a choke to a choke list [OC = Other Corners]
(define (AddChoke Corner OC ChokeList)
  (cons (Choke (LR Corner 0) (LR Corner 1) (MakePaths Corner (RFL Corner OC))) ChokeList))

;Builds a list of paths to be put into a new choke
(define (MakePaths Corner OC)
  (cond ((empty? OC) '())
        ((not (OnWall? (LR Corner 0) (LR Corner 1) (LR (first OC) 0) (LR (first OC) 1)))
         (cons (Path (LR (first OC) 0) (LR (first OC) 1))
               (MakePaths Corner (rest OC))))
        (else (MakePaths Corner (rest OC)))))

;Finds the 2Dimensional distance between two points represented as lists
(define (PitaDistance P1 P2)
  (sqrt (+ (expt (- (LR P1 0) (LR P2 0)) 2) (expt (- (LR P1 1) (LR P2 1)) 2))))

;Returns true if the line that goes between the two coordinate sets crosses a wall
(define (OnWall? X1 Y1 X2 Y2) (AreThereWalls? (GetTerrain) (BuildLine X1 Y1 X2 Y2)))

;Used by OnWall?, checks if any of the points in LTC are a Wall section on the current Terrain
(define (AreThereWalls? Terrain LTC)
  (cond ((empty? LTC) #f)
        ((equal? (Pos2D Terrain (LR (first LTC) 0) (LR (first LTC) 1)) -Wall) #t)
        (else (AreThereWalls? Terrain (rest LTC)))))

;Builds a list representing all the cell coordinates of a line between two points
(define (BuildLine X1 Y1 X2 Y2)
  (cond ((= (- X2 X1) 0) (VerticalLine Y1 Y2 X1 (DirRBL Y1 Y2)))
        (else (ArcedLine X1 Y1 X2 Y2 (/ (- Y2 Y1) (- X2 X1))))))

;Runs the linelist creator for a vertical line
(define (VerticalLine Y1 Y2 X ve)
  (cond ((= Y1 Y2) (list (list X Y2)))
        (else (cons (list X Y1) (VerticalLine (ve Y1 1) Y2 X ve)))))

;Runs the linelist creator for any line that is not horizontal
(define (ArcedLine X1 Y1 X2 Y2 M)
  (RunBuildLine X1 Y1 X2 Y2 M (- Y1 (* M X1)) (DirRBL X1 X2) (DirRBL Y1 Y2)))

;Iterates through additions of cell coordinates to a linelist
(define (RunBuildLine X1 Y1 X2 Y2 M N hr ve)
  (cond ((and (= X1 X2) (= Y1 Y2)) (list (list X2 Y2)))
        ((< (ApproxF1 (hr X1 1) Y1 M N) (ApproxF1 X1 (ve Y1 1) M N))
         (cons (list X1 Y1) (RunBuildLine (hr X1 1) Y1 X2 Y2 M N hr ve)))
        (else (cons (list X1 Y1) (RunBuildLine X1 (ve Y1 1) X2 Y2 M N hr ve)))))

;Returns the priority of moving towards a specific direction on a line
(define (ApproxF1 X Y M N) (abs (- (+ (* M X) N) Y)))

;Determines which direction should be checked when advancing through a line
(define (DirRBL T1 T2) (cond ((>= (- T2 T1) 0) +) (else -)))

;====================================================================================================

;          [ Map Database ]

(define Abadon (Build+CL (BuildMap 20 '(0 0) '(7 10) (list ;(PaintMap Abadon)
100010101 103000303 101040404 100060106 104050409 108070811 109111211 113091313 105051005 111091104
109080908 107090609 106100612 104130913 109140917 104190415 108160516 114131513 117141711 115151915
113081708))))
(Println "* Map [%] Compiled" "Abadon") ;Instant

(define Hive (BuildMap 80 '(28 49) '(51 63) (list ;(PaintMap Hive) '(0 0) '(75 68)
152205237 137422338 135455362 166567171 170367019 144062004 106241345 105632269 240514557 211554067
260617365 239245727 207322539 127173824 163457047 169606966 154733773 129563065 118591358 178427654
176086310 159186123 144293131 114141208 102100617 107270230 205111225 252466758 266107622 230053620
229393647 138663979 173757778 117761378 110513551 147484914 149174318 118211953 150615067 146665965
158705848 156527153 249305034 119332634 160307331 177387943 171157919 274177721 151085500 254055708
120732779 )))
(Println "* Map [%] Compiled" "Hive") ;6 Seconds

(define Omega (BuildMap 80 '(0 0) '(31 30) (list ;(PaintMap Omega) (6 21)
113102727 117350145 102500043 210132422 204331442 125282338 127421737 144185233 146262526 130303029
166315048 158736042 168702067 125412454 118543653 135453360 130464448 256306242 258375239 253214725
217211923 219352040 213381739 230172620 146313833 140304038 130354036 135173500 136034708 239054309
241614669 143554961 124581062 166557960 145743879 150765170)))
(Println "* Map [%] Compiled" "Omega") ;2 Seconds

(define Extra (BuildMap 320 '(0 0) '(319 319) (list ;(PaintMap Extra)
134349999 235359898 1100100200200 1127045172076 1135200155319 1210150290170)))
(Println "* Map [%] Compiled" "Extra") ;1 Second

;====================================================================================================

(define -GroundColor (RGB 90 120 200))
(define -WallColor Black)
(define -CornerColor (RGB 75 150 255))
(define -PathColor (RGB 200 220 255))
(define -StartColor Green)
(define -EndColor Green)
(define -OutputPath White)

(Println " - Commands: (PaintMap Map) (Run Map)")