#lang scheme




(provide
		
		(rename-out (create-world-from-file create-world))
		(rename-out (register-robot! create-robot))
		(rename-out (simulate! simulate-world))
		
		feel-robot?
		smell-robot?
		look-robot?
		
		grab-robot!
		zap-robot!
		
		turn-robot!
		move-robot!
		
		simulate-robot)




(require scheme/gui/base)

(require scheme/runtime-path)




(define (resolve-tile-path identifier)
	(build-path resolve-base-path 'up (string->path "resources")
		(string->path (string-append (symbol->string identifier) ".png"))))

(define (resolve-tiles-path identifier)
	(build-path resolve-base-path 'up (string->path "resources")
		(string->path (string-append (symbol->string identifier) ".map"))))

(define-runtime-path resolve-base-path ".")




(define-struct world
	(tiles robots observers))

(define-struct tiles
	(width height matrix))

(define-struct robot
	(
		world identifier
		position direction
		behaviour
		continuation continuation-tag)
	#:mutable)

(define-struct position
	(x y))




(define (feel-robot? robot (thing '(food prize)) (direction #f))
	
	(define target
		(position-neighbour
			(robot-position robot)
			(if direction direction (robot-direction robot))))
	
	(define world (robot-world robot))
	(define tile (world-tile world target))
	
	(which-thing? thing tile))

(define (smell-robot? robot (thing '(food prize)))
	
	(define position (robot-position robot))
	
	(define world (robot-world robot))
	
	(for*/or
			((dx (in-range -1 2))
			(dy (in-range -1 2))
			#:when (not (and (= dx 0) (= dy 0))))
		
		(define tile (world-tile world (position-translated position dx dy)))
		
		(which-thing? thing tile)))

(define (look-robot? robot (thing '(food prize)))
	(look-robot-aux? robot thing (robot-direction robot) (robot-position robot) 0))

(define (look-robot-aux? robot thing direction old-target looked)
	
	(define new-target (position-neighbour old-target direction))
	
	(define world (robot-world robot))
	(define tile (world-tile world new-target))
	
	(cond
		
		((which-thing? thing tile)
			;(values tile (+ looked 1)))
			(+ looked 1))
		
		((eq? 'space tile)
			(look-robot-aux? robot thing direction new-target (+ looked 1)))
		
		(else
			;(values #f (+ looked 1)))))
			#f)))

(define (which-thing? thing tile)
	(if (list? thing)
		(if (member tile thing)
			tile
			#f)
		(if (eq? tile thing)
			tile
			#f)))




(define (grab-robot! robot (direction #f))
	
	(define target
		(position-neighbour
			(robot-position robot)
			(if direction direction (robot-direction robot))))
	
	(define world (robot-world robot))
	(define tile (world-tile world target))
	
	(case tile
		
		((prize)
			(update-world-tile! world target 'space)
			(exit-robot! robot)
			tile)
		
		((food)
			(update-world-tile! world target 'space)
			(exit-robot! robot)
			tile)
		
		((baddie)
			(exit-robot! robot)
			tile)
		
		(else
			(exit-robot! robot)
			#f)))

(define (zap-robot! robot (direction #f))
	
	(define target
		(position-neighbour
			(robot-position robot)
			(if direction direction (robot-direction robot))))
	
	(define world (robot-world robot))
	(define tile (world-tile world target))
	
	(case tile
		
		((prize)
			(update-world-tile! world target 'space)
			(exit-robot! robot)
			tile)
		
		((food)
			(update-world-tile! world target 'space)
			(exit-robot! robot)
			tile)
		
		((baddie)
			(update-world-tile! world target 'space)
			(exit-robot! robot)
			tile)
		
		(else
			(exit-robot! robot)
			#f)))




(define (turn-robot! robot (increment 1))
	
	(define new-direction
		(number->direction
			(+ increment
				(direction->number
					(robot-direction robot)))))
	
	(set-robot-direction! robot new-direction)
	(update-world-tile! (robot-world robot) (robot-position robot) (direction->tile new-direction))
	(exit-robot! robot)
	
	#t)

(define (move-robot! robot (increment 1))
	(move-robot-aux! robot (robot-direction robot) increment 0))

(define (move-robot-aux! robot direction remaining moved)
	(cond
		((zero? remaining)
			moved)
		((move-robot-forward! robot direction)
			(move-robot-aux! robot direction (- remaining 1) (+ moved 1)))
		(else
			moved)))

(define (move-robot-forward! robot direction)
	
	(define old-position (robot-position robot))
	(define new-position (position-neighbour old-position direction))
	(define world (robot-world robot))
	
	(case (world-tile (robot-world robot) new-position)
		
		((space)
			(set-robot-position! robot new-position)
			(update-world-tile! world old-position 'space)
			(update-world-tile! world new-position (direction->tile (robot-direction robot)))
			(exit-robot! robot)
			#t)
		
		(else
			#f)))




(define (position-neighbour old-position direction)
	
	(define old-x (position-x old-position))
	(define old-y (position-y old-position))
	
	(define-values (new-x new-y)
		(case direction
			((east) (values (+ old-x 1) old-y))
			((north) (values old-x (- old-y 1)))
			((west) (values (- old-x 1) old-y))
			((south) (values old-x (+ old-y 1)))
			(else (values old-x old-y))))
	
	(make-position new-x new-y))

(define (position-translated old-position dx dy)
	
	(make-position
		(+ (position-x old-position) dx)
		(+ (position-y old-position) dy)))




(define (direction->number direction)
	(hash-ref direction-to-number-hash direction #f))

(define (number->direction number)
	(hash-ref number-to-direction-hash (modulo number 4) #f))

(define (direction->tile direction)
	(hash-ref direction-to-tile-hash direction #f))

(define direction-to-number-hash
	(make-immutable-hasheq
		'((east . 0) (north . 1) (west . 2) (south . 3))))

(define number-to-direction-hash
	(make-immutable-hasheq
		'((0 . east) (1 . north) (2 . west) (3 . south))))

(define direction-to-tile-hash
	(make-immutable-hasheq
		'((east . robot-east) (north . robot-north) (west . robot-west) (south . robot-south))))




(define (create-world tiles)
	(make-world tiles (make-hash) (box null)))

(define (create-world-from-file path)
	(create-world (create-tiles-from-file path)))




(define (world-width world)
	(tiles-width (world-tiles world)))

(define (world-height world)
	(tiles-height (world-tiles world)))

(define (world-tile world position)
	(tiles-tile (world-tiles world) (position-x position) (position-y position)))

(define (world-tiles-lambda world)
	(lambda (position)
		(world-tile world position)))

(define (update-world-tile! world position (tile #f))
	
	(when tile
		(set-tiles-tile! (world-tiles world) (position-x position) (position-y position) tile))
	
	(notify-observers! world position)
	
	(void))




(define (world-robot world identifier)
	(hash-ref (world-robots world) identifier #f))

(define (register-robot! world identifier behaviour (xy-random #t))
	
	(define tiles (world-tiles world))
	(define robots (world-robots world))
	(define width (tiles-width tiles))
	(define height (tiles-height tiles))
	
	(define position
		(if xy-random
			(do
					((x (random width) (random width))
					(y (random height) (random height)))
					((eq? (tiles-tile tiles x y) 'space)
					(make-position x y)))
			(for*/first
					((x (in-range width))
					(y (in-range height))
					#:when (eq? (tiles-tile tiles x y) 'space))
				(make-position x y))))
	
	(define direction 'south)
	
	(define robot
		(make-robot
			world identifier
			position direction
			behaviour
			(void) (make-continuation-prompt-tag)))
	
	(hash-set! (world-robots world) identifier robot)
	
	(update-world-tile! world position (direction->tile direction))
	
	robot)




(define (register-observer! world observer)
	
	(define observers (world-observers world))
	
	(set-box! observers
		(cons observer (unbox observers)))
	
	(void))

(define (notify-observers! world position)
	
	(for* ((observer (in-list (unbox (world-observers world)))))
		(observer position))
	
	(void))




(define (step-world! world)
	
	(for ((robot (in-hash-values (world-robots world))))
		(cond
			((void? (robot-continuation robot))
				(start-robot! robot))
			((continuation? (robot-continuation robot))
				(enter-robot! robot))))
	
	(void))




(define (start-robot! robot)
	
	(call-with-continuation-prompt
		(lambda ()
			(call-with-current-continuation
				(lambda (framework-continuation)
					(set-robot-continuation! robot framework-continuation)
					(set! framework-continuation (void))
					(exit-robot! robot)
					((robot-behaviour robot) robot)
					(set! framework-continuation (robot-continuation robot))
					(set-robot-continuation! robot #f)
					(framework-continuation (void)))
				(robot-continuation-tag robot)))
		(robot-continuation-tag robot)))

(define (enter-robot! robot)
	
	(call-with-continuation-prompt
		(lambda ()
			(call-with-current-continuation
				(lambda (new-framework-continuation)
					(define old-behaviour-continuation (robot-continuation robot))
					(set-robot-continuation! robot new-framework-continuation)
					(old-behaviour-continuation (void)))
				(robot-continuation-tag robot)))
		(robot-continuation-tag robot)))

(define (exit-robot! robot)
	
	(call-with-current-continuation
		(lambda (new-behaviour-continuation)
			(define old-framework-continuation (robot-continuation robot))
			(set-robot-continuation! robot new-behaviour-continuation)
			(old-framework-continuation (void)))
		(robot-continuation-tag robot)))




(define (create-tiles* width height)
	
	(define matrix
		(list->vector
			(for/list ((x (in-range width)))
				(list->vector
					(for/list ((y (in-range height)))
						'wall)))))
	
	(make-tiles width height matrix))

(define (tiles-tile tiles x y)
	(if (and (< -1 x (tiles-width tiles)) (< -1 y (tiles-height tiles)))
		(vector-ref (vector-ref (tiles-matrix tiles) x) y)
		'unknown))

(define (set-tiles-tile! tiles x y v)
	(vector-set! (vector-ref (tiles-matrix tiles) x) y v))

(define (create-tiles-from-lines lines)
	
	(define height (length lines))
	(define width (string-length (argmax string-length lines)))
	(define tiles (create-tiles* width height))
	
	(for
			((line (in-list lines))
			(y (in-naturals 0)))
		(for
				((tile (in-string line))
				(x (in-naturals 0)))
			(vector-set! (vector-ref (tiles-matrix tiles) x) y
				(case tile
					((#\#) 'wall)
					((#\space) 'space)
					((#\$) 'prize)
					((#\+) 'food)
					((#\@) 'baddie)
					(else #f)))))
	
	tiles)

(define (create-tiles-from-port port)
	
	(define (collect collected)
		(define line (read-line port 'any))
		(if (eof-object? line)
			(reverse collected)
			(collect (cons line collected))))
	
	(define lines (collect null))
	
	(create-tiles-from-lines lines))

(define (create-tiles-from-file path)
	
	(define realpath
		(if (symbol? path)
			(resolve-tiles-path path)
			path))
	
	(call-with-input-file* realpath create-tiles-from-port #:mode 'text))




(define-struct tile-buffer
	(
		width height
		tiles
		bitmap bitmap-dc))

(define (create-tile-buffer width height tiles)
	
	(define bitmap
		(make-object bitmap% (* width tile-bitmap-width) (* height tile-bitmap-height)))
	(define bitmap-dc
		(make-object bitmap-dc% bitmap))
	
	(define buffer
		(make-tile-buffer width height tiles bitmap bitmap-dc))
	
	(refresh-tile-buffer! buffer)
	
	buffer)

(define (tile-buffer-pixel-width buffer)
	(* (tile-buffer-width buffer) tile-bitmap-width))

(define (tile-buffer-pixel-height buffer)
	(* (tile-buffer-height buffer) tile-bitmap-height))

(define (refresh-tile-buffer! buffer (positions #f))
	
	(define bitmap-dc (tile-buffer-bitmap-dc buffer))
	
	(cond
		((position? positions)
			(send bitmap-dc draw-bitmap
				(tile-bitmap ((tile-buffer-tiles buffer) positions))
				(* (position-x positions) tile-bitmap-width) (* (position-y positions) tile-bitmap-height)))
		((list? positions)
			(for ((position (in-list positions)))
				(send bitmap-dc draw-bitmap
					(tile-bitmap ((tile-buffer-tiles buffer) position))
					(* (position-x position) tile-bitmap-width) (* (position-y position) tile-bitmap-height))))
		((false? positions)
			(for*
					((x (in-range (tile-buffer-width buffer)))
					(y (in-range (tile-buffer-height buffer))))
				(send bitmap-dc draw-bitmap
					(tile-bitmap ((tile-buffer-tiles buffer) (make-position x y)))
					(* x tile-bitmap-width) (* y tile-bitmap-height))))
		(else
			#f))
	
	(void))




(define (tile-bitmap identifier)
	(hash-ref tile-to-bitmap-hash identifier #f))

(define (create-tile-bitmap identifier)
	(make-object bitmap% (resolve-tile-path identifier)))

(define tile-bitmap-width 16)
(define tile-bitmap-height 16)

(define tile-identifiers
	(list 'baddie 'food 'prize 'robot-east 'robot-north 'robot-south 'robot-west 'space 'wall))

(define tile-to-bitmap-hash
	(make-immutable-hasheq
		(for/list ((identifier (in-list tile-identifiers)))
			(cons identifier (create-tile-bitmap identifier)))))




(define (simulate! world (heartbeat 100))
	
	
	(define (canvas-paint-callback canvas dc)
		(send dc draw-bitmap (tile-buffer-bitmap buffer) 0 0)
		(void))
	
	(define (timer-notify-callback)
		(step-world! world)
		(send (send canvas get-dc) draw-bitmap (tile-buffer-bitmap buffer) 0 0)
		;(send canvas refresh)
		(void))
	
	(define (exit-callback button event)
		(send timer stop)
		(send frame show #f)
		(void))
	
	(define (observer position)
		(refresh-tile-buffer! buffer position)
		(void))
	
	
	(define buffer
		(create-tile-buffer
			(world-width world) (world-height world)
			(world-tiles-lambda world)))
	
	
	(define frame
		(new frame%
			(label "PLT Robots")
			(width 640)
			(height 480)))
	
	(define menu-panel
		(new horizontal-panel%
			(parent frame)
			(alignment '(left center))
			(stretchable-height #f)))
	
	(define canvas-panel
		(new vertical-panel%
			(parent frame)
			(alignment '(center center))))
	
	(define exit
		(new button%
			(parent menu-panel)
			(label "Exit")
			(callback exit-callback)))
	
	(define status
		(new message%
			(parent menu-panel)
			(label "...")))
	
	(define canvas
		(new canvas%
			(parent canvas-panel)
			(paint-callback canvas-paint-callback)
			(min-width (tile-buffer-pixel-width buffer))
			(min-height (tile-buffer-pixel-height buffer))
			(stretchable-width #f)
			(stretchable-height #f)
		))
	
	(define timer
		(new timer%
			(interval heartbeat)
			(notify-callback timer-notify-callback)))
	
	
	(register-observer! world observer)
	
	(send frame show #t)
	
	(void))




(define (simulate-robot behaviour (tiles 'small))
	(define world (create-world-from-file tiles))
	(define robot (register-robot! world 'robot behaviour))
	(simulate! world)
	(void))