view src/lifter.tp @ 61:f851895ea67a

Add cullwhenover option and more tuning results
author Mike Pavone <pavone@retrodev.com>
date Mon, 16 Jul 2012 02:20:38 -0700
parents 7d4e51b4769a
children ff2b38518a58
line wrap: on
line source

#{
	swap <- :arr from to {
		a <- arr get: from
		b <- arr get: to
		arr set: from b
		arr set: to a
	}
	
	median <- :arr idx1 idx2 idx3 {
		val1 <- (arr get: idx1) heuristic
		val2 <- (arr get: idx2) heuristic
		val3 <- (arr get: idx3) heuristic
		
		if: val2 > val1 {
			if: val3 > val2 {
				idx2
			} else: {
				if: val3 > val1 {
					idx3
				} else: {
					idx1
				}
			}
		} else: {
			//val1 >= val2
			if: val3 > val1 {
				idx1
			} else: {
				//val1 >= val3
				if: val3 > val2 {
					idx3
				} else: {
					idx2
				}
			}
		}
	}
	
	partition <- :arr left right pivotidx {
		pivotval <- (arr get: pivotidx) heuristic
		//move pivot to end
		swap: arr pivotidx right
		i <- left
		storeidx <- left
		while: { i < right } do: {
			if: ((arr get: i) heuristic) < pivotval {
				swap: arr storeidx i
				storeidx <- storeidx + 1
			}
			i <- i + 1
		}
		swap: arr storeidx right
		storeidx
	}
	
	//quickselect shamelessly translated from pseudocode on Wikipedia
	select <- :arr left right n {
		pivotidx <- median: arr left right (left + (right - left) / 2)
		newpivotidx <- partition: arr left right pivotidx
		pivotdist <- newpivotidx - left + 1
		while: { pivotdist != n } do: {
			if: n < pivotdist {
				right <- newpivotidx - 1
			} else: {
				n <- n - pivotdist
				left <- newpivotidx + 1
			}
			pivotidx <- median: arr left right (left + (right - right) / 2)
			newpivotidx <- partition: arr left right pivotidx
			pivotdist <- newpivotidx - left + 1
		}
		newpivotidx
	}
	
	topN <- :arr n {
		curidx <- (select: arr 0 (arr length) - 1 ((arr length) - n)) + 1
		newarr <- #[]
		while: { curidx < (arr length) } do: {
			newarr append: (arr get: curidx)
			curidx <- curidx + 1
		}
		newarr
	}
	
	printArr <- :arr {
		foreach: arr :idx el {
			print: "" . idx . ": " . (el heuristic) . "\n"
		}
	}
	
	abs <- :val {
		if: val < 0 { 0 - val } else: { val }
	}
	
	distanceFrom:to <- :sx sy :dx dy {
		(abs: sx - dx) + (abs: sy - dy)
	}
	
	moveFinder <- :field {
		#{
			curbest <- (field clone) advance: "A"
			states <- #[field]
			visitedStates <- sets hash
			bestMove:withMaxSteps <- :self :max{
				n <- 0
				hashelim <- 0
				while: { if: (states length) > 0 { if: n < max { not: (curbest succeeded) } } } do: {
					nextstates <- #[]
					foreach: states :idx curstate {
						me <-curstate getRobot
						candidates <- curstate validMoves: (me x) (me y)
						foreach: candidates :idx move {
							curfield <- curstate clone
							curfield advance: (move cmd)
							if: (not: (visitedStates contains?: curfield)) {
								visitedStates add: curfield
								if: (curfield ended) {
									if: (curfield score) > (curbest score) {
										curbest <- curfield
									}
								} else: {
									//check theoretical max score for current map state
									//discard paths that can never be better than our current best
									if: (curfield maxScore) > (curbest score) {
										nextstates append: curfield
									}
								}
							}
						}
					}
					states <- nextstates
					n <- n + 1
				}
				if: (curbest succeeded) {
					false
				} else: {
					(states length) > 0
				}
			}
			cullStatesTo <- :n {
				os write: 2 "culling " . (states length) . " to " . n . "\n"
				if: n < (states length) {
					states <- topN: states n
				}
				os write: 2 "states length is now " . (states length) . "\n"
			}
		}
	}
	
	main <- :args {
		initmaxsteps <- 6
		aftermaxsteps <- 5
		cullstates <- 8
		curarg <- 1
		cullwhenover <- 0
		while: { curarg < (args length) } do: {
			if: (args get: curarg) = "-is" {
				curarg <- curarg + 1
				if: curarg < (args length) {
					initmaxsteps <- ((args get: curarg) int32)
				}
			} else: {
				if: (args get: curarg) = "-as" {
					curarg <- curarg + 1
					if: curarg < (args length) {
						aftermaxsteps <- ((args get: curarg) int32)
					}
				} else: {
					if: (args get: curarg) = "-cs" {
						curarg <- curarg + 1
						if: curarg < (args length) {
							cullstates <- ((args get: curarg) int32)
						}
					} else: {
						if: (args get: curarg) = "-co" {
							curarg <- curarg + 1
							if: curarg < (args length) {
								cullwhenover <- ((args get: curarg) int32)
							}	
						}
					}
				}
			}
			curarg <- curarg + 1
		}
		
		text <- sim readFd: 0
		initial <- (sim state) fromStr: text
		os write: 2 text
		os write: 2 "width: " . (string: (initial width)) . "\n"
		os write: 2 "height: " . (string: (initial height)) . "\n"
		
		finder <- moveFinder: initial
		
		maxsteps <- initmaxsteps
		while: { bestMove: finder withMaxSteps: maxsteps } do: {
			//best <- -1000000
			//bestscore <- -1000000
			//foreach: (finder states) :idx el {
			//	h <- (el heuristic)
			//	s <- (el score)
			//	if: (h > best) {
			//		best <- h
			//	}
			//	if: (s > bestscore) {
			//		bestscore <- s
			//	}
			//}
			if: ((finder states) length) > cullwhenover {
				finder cullStatesTo: cullstates
			}
			maxsteps <- aftermaxsteps
			os write: 2 "--------iteration results-------\n"
			os write: 2 "Best:\n"
			(finder curbest) printGrid
			//os write: 2 "Hash: " . ((finder curbest) hash)
			//os write: 2 "Current before cull\n"
			//os write: 2 " Best Heuristic: " . best . "\n"
			//os write: 2 " Best Score: " . bestscore . "\n"
			//os write: 2 "After cull:\n"
			//foreach: (finder states) :idx el{
			//	os write: 2 " " . idx . " Heuristic: " . (el heuristic) . "\n"
			//	os write: 2 " " . idx . " Score: " . (el score) . "\n"
			//}
			//os write: 2 "Current:\n"
			//(finder playfield) printGrid
		}
		os write: 2 "---------------\n"
		os write: 2 "End Best:\n"
		(finder curbest) printGrid
		0
	}
}