Mercurial > repos > icfp2013

changeset 28:6384e577842d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add code for filtering a program set based on the operators used
author Mike Pavone <pavone@retrodev.com>
date Sat, 10 Aug 2013 18:35:10 -0700
parents 655d5b19333d
children 3690601c8c70
files src/bv.tp
diffstat 1 files changed, 374 insertions(+), 264 deletions(-) [+]
line wrap: on
line diff
--- a/src/bv.tp	Sat Aug 10 17:25:33 2013 -0700
+++ b/src/bv.tp	Sat Aug 10 18:35:10 2013 -0700
@@ -1,297 +1,407 @@
-#{
-	program <- {
-		_input <- 0u64
-		_acc <- 0u64
-		_val <- 0u64
-		_zero <- #{
-			string <- { "0" }
-			eval <- { 0u64 }
-		}
-
-		_one <- #{
-			string <- { "1" }
-			eval <- { 1u64 }
-		}
-
-		_inputNode <- #{
-			string <- { "input" }
-			eval <- { _input }
-		}
-		_accNode <- #{
-			string <- { "acc" }
-			eval <- { _acc }
-		}
-		_valNode <- #{
-			string <- { "val" }
-			eval <- { _val }
-		}
-		_memo <- #[]
-		_memoFoldBody <- #[]
-		_memoFoldParam <- #[]
-		#{
-			plus <- :left right {
-				#{
-					string <- { "(plus " . (string: left) . " " . (string: right) . ")" }
-					eval <- { (eval: left) + (eval: right)}
-				}
-			}
-			zero <- {
-				_zero
+{
+	#{
+		program <- {
+			_input <- 0u64
+			_acc <- 0u64
+			_val <- 0u64
+			_zero <- #{
+				string <- { "0" }
+				eval <- { 0u64 }
+				operators <- { 0 }
+				isTfold? <- { false }
+				isTerminal? <- { true }
 			}
 
-			one <- {
-				_one
-			}
-
-			opAnd <- :left right {
-				#{
-					string <- { "(and " . (string: left) . " " . (string: right) . ")" }
-					eval <- { (eval: left) and (eval: right)}
-				}
+			_one <- #{
+				string <- { "1" }
+				eval <- { 1u64 }
+				operators <- { 0 }
+				isTfold? <- { false }
+				isTerminal? <- { true }
 			}
 
-			opOr <- :left right {
-				#{
-					string <- { "(or " . (string: left) . " " . (string: right) . ")" }
-					eval <- { (eval: left) or (eval: right)}
+			_inputNode <- #{
+				string <- { "input" }
+				eval <- { _input }
+				operators <- { 0 }
+				isTfold? <- { false }
+				isTerminal? <- { true }
+			}
+			_accNode <- #{
+				string <- { "acc" }
+				eval <- { _acc }
+				operators <- { 0 }
+				isTfold? <- { false }
+				isTerminal? <- { true }
+			}
+			_valNode <- #{
+				string <- { "val" }
+				eval <- { _val }
+				operators <- { 0 }
+				isTfold? <- { false }
+				isTerminal? <- { true }
+			}
+			_opPlus <- 1
+			_opAnd <- 2
+			_opOr <- 4
+			_opXor <- 8
+			_opNot <- 0x10
+			_opShl1 <- 0x20
+			_opShr1 <- 0x40
+			_opShr4 <- 0x80
+			_opShr16 <- 0x100
+			_opIf0 <- 0x200
+			_opFold <- 0x400
+			_opTfold <- 0x800
+			_maskRemoveFold <- 0x3FF
+			_names <- dict linear
+			_names set: "plus" _opPlus
+			_names set: "and" _opAnd
+			_names set: "xor" _opXor
+			_names set: "or" _opOr
+			_names set: "not" _opNot
+			_names set: "shl1" _opShl1
+			_names set: "shr1" _opShr1
+			_names set: "shr4" _opShr4
+			_names set: "shr16" _opShr16
+			_names set: "if0" _opIf0
+			_names set: "fold" _opFold
+			_names set: "tfold" _opTfold
+			_memo <- #[]
+			_memoFoldBody <- #[]
+			_memoFoldParam <- #[]
+			#{
+				plus <- :left right {
+					#{
+						string <- { "(plus " . (string: left) . " " . (string: right) . ")" }
+						eval <- { (eval: left) + (eval: right)}
+						operators <- { _opPlus or (left operators) or (right operators)}
+						isTfold? <- { false }
+						isTerminal? <- { false }
+					}
 				}
-			}
+				zero <- {
+					_zero
+				}
 
-			opXor <- :left right {
-				#{
-					string <- { "(xor " . (string: left) . " " . (string: right) . ")" }
-					eval <- { (eval: left) xor (eval: right)}
+				one <- {
+					_one
 				}
-			}
 
-			opNot <- :exp {
-				#{
-					string <- { "(not " . (string: exp) . ")" }
-					eval <- { (eval: exp) xor -1u64 }
+				opAnd <- :left right {
+					#{
+						string <- { "(and " . (string: left) . " " . (string: right) . ")" }
+						eval <- { (eval: left) and (eval: right)}
+						operators <- { _opAnd or (left operators) or (right operators)}
+						isTfold? <- { false }
+						isTerminal? <- { false }
+					}
+				}
+
+				opOr <- :left right {
+					#{
+						string <- { "(or " . (string: left) . " " . (string: right) . ")" }
+						eval <- { (eval: left) or (eval: right)}
+						operators <- { _opOr or (left operators) or (right operators)}
+						isTfold? <- { false }
+						isTerminal? <- { false }
+					}
 				}
-			}
+
+				opXor <- :left right {
+					#{
+						string <- { "(xor " . (string: left) . " " . (string: right) . ")" }
+						eval <- { (eval: left) xor (eval: right)}
+						operators <- { _opXor or (left operators) or (right operators)}
+						isTfold? <- { false }
+						isTerminal? <- { false }
+					}
+				}
+
+				opNot <- :exp {
+					#{
+						string <- { "(not " . (string: exp) . ")" }
+						eval <- { (eval: exp) xor -1u64 }
+						operators <- { _opNot or (exp operators)}
+						isTfold? <- { false }
+						isTerminal? <- { false }
+					}
+				}
 
-			shl1 <- :exp {
-				#{
-					string <- { "(shl1 " . (string: exp) . ")" }
-					eval <- { lshift: (eval: exp) by: 1u64 }
+				shl1 <- :exp {
+					#{
+						string <- { "(shl1 " . (string: exp) . ")" }
+						eval <- { lshift: (eval: exp) by: 1u64 }
+						operators <- { _opShl1 or (exp operators)}
+						isTfold? <- { false }
+						isTerminal? <- { false }
+					}
+				}
+
+				shr1 <- :exp {
+					#{
+						string <- { "(shr1 " . (string: exp) . ")" }
+						eval <- { rshift: (eval: exp) by: 1u64 }
+						operators <- { _opShr1 or (exp operators)}
+						isTfold? <- { false }
+						isTerminal? <- { false }
+					}
 				}
-			}
+
+				shr4 <- :exp {
+					#{
+						string <- { "(shr4 " . (string: exp) . ")" }
+						eval <- { rshift: (eval: exp) by: 4u64 }
+						operators <- { _opShr4 or (exp operators)}
+						isTfold? <- { false }
+						isTerminal? <- { false }
+					}
+				}
+
+				shr16 <- :exp {
+					#{
+						string <- { "(shr16 " . (string: exp) . ")" }
+						eval <- { rshift: (eval: exp) by: 16u64 }
+						operators <- { _opShr16 or (exp operators)}
+						isTfold? <- { false }
+						isTerminal? <- { false }
+					}
+				}
+
+				input <- { _inputNode }
+				acc <- { _accNode }
+				val <- { _valNode }
 
-			shr1 <- :exp {
-				#{
-					string <- { "(shr1 " . (string: exp) . ")" }
-					eval <- { rshift: (eval: exp) by: 1u64 }
+				if0:then:else <- :exp ifzero :ifnotzero {
+					#{
+						string <- { "(if0 " . (string: exp) . " " . (string: ifzero) . " " . (string: ifnotzero) . ")" }
+						eval <- {
+							if: (eval: exp) = 0u64 {
+								eval: ifzero
+							} else: {
+								eval: ifnotzero
+							}
+						}
+						operators <- { _opIf0 or (exp operators) or (ifzero operators) or (ifnotzero operators)}
+						isTfold? <- { false }
+						isTerminal? <- { false }
+					}
 				}
-			}
 
-			shr4 <- :exp {
-				#{
-					string <- { "(shr4 " . (string: exp) . ")" }
-					eval <- { rshift: (eval: exp) by: 4u64 }
+				fold:with:startingAt <- :toFold :fun :startAcc {
+					#{
+						string <- {
+							"(fold " . (string: toFold) . " " . (string: startAcc) . " (lambda (val acc) " . (string: fun) . "))"
+						}
+						eval <- {
+							_acc <- (eval: startAcc)
+							source <- (eval: toFold)
+							//parser doesn''t currently like vertical whitespace in arays so
+							//this needs to be on a single line until that bug is fixed
+							vals <- #[source and 255u64 (rshift: source by: 8u64) and 255u64 (rshift: source by: 16u64) and 255u64 (rshift: source by: 24u64) and 255u64 (rshift: source by: 32u64) and 255u64 (rshift: source by: 40u64) and 255u64 (rshift: source by: 48u64) and 255u64 (rshift: source by: 56u64) and 255u64]
+							foreach: vals :idx cur {
+								_val <- cur
+								_acc <- (eval: fun)
+							}
+							_acc
+						}
+						operators <- { _opFold or (toFold operators) or (fun operators) or (startAcc operators) }
+						isTfold? <- {
+							(toFold isTerminal?) && (startAcc isTerminal?) && (toFold string) = "input" && (startAcc string) = "0"
+						}
+						isTerminal? <- { false }
+					}
 				}
-			}
+
+				run <- :in {
+					_input <- in
+					eval: root
+				}
+
+				root <- _zero
+
+				string <- {
+					"(lambda (input) " . (string: root) . ")"
+				}
+
+				gentestprog <- {
+					root <- if0: (opAnd: input one) then: (
+						plus: (opOr: input (shl1: one))
+					) else: (
+						opXor: input (shr16: input)
+					)
+					self
+				}
+
+				exampleprog <- {
+					root <- fold: input with: (opOr: val acc) startingAt: zero
+					self
+				}
 
-			shr16 <- :exp {
-				#{
-					string <- { "(shr16 " . (string: exp) . ")" }
-					eval <- { rshift: (eval: exp) by: 16u64 }
-				}
-			}
-
-			input <- { _inputNode }
-			acc <- { _accNode }
-			val <- { _valNode }
-
-			if0:then:else <- :exp ifzero :ifnotzero {
-				#{
-					string <- { "(if0 " . (string: exp) . " " . (string: ifzero) . " " . (string: ifnotzero) . ")" }
-					eval <- {
-						if: (eval: exp) = 0u64 {
-							eval: ifzero
+				//TODO: memoize this to improve runtime for large n
+				allOfSize:inFold? <- :n :infold? {
+					memo <- if: infold? = 2 {
+						_memoFoldBody
+					} else: {
+						if: infold? = 1 && n > 4 {
+							_memoFoldParam
+						} else: {
+							_memo
+						}
+					}
+					if: n - 1 < (memo length) {
+						print: "Memo hit: " . (string: n) . "\n"
+						memo get: (n - 1)
+					} else: {
+						if: n = 1 {
+							res <- #[one zero input]
+							if: infold? = 2 {
+								res append: acc
+								res append: val
+							}
+							print: "Saving at memo index: " . (string: (memo length)) . "\n"
+							memo append: res
+							res
 						} else: {
-							eval: ifnotzero
+							res <- #[]
+							foreach: (allOfSize: n - 1 inFold?: infold?) :idx exp {
+								res append: (opNot: exp)
+								res append: (shl1: exp)
+								res append: (shr1: exp)
+								res append: (shr4: exp)
+								res append: (shr16: exp)
+							}
+							if: n > 2 {
+								numLeft <- 1
+								argTotal <- n - 1
+								while: { numLeft < argTotal } do: {
+									numRight <- argTotal - numLeft
+									choicesRight <- (allOfSize: numRight inFold?: infold?)
+									foreach: (allOfSize: numLeft inFold?: infold?) :idx leftExp {
+										foreach: choicesRight :idx rightExp {
+											res append: (opAnd: leftExp rightExp)
+											res append: (opOr: leftExp rightExp)
+											res append: (opXor: leftExp rightExp)
+											res append: (plus: leftExp rightExp)
+										}
+									}
+									numLeft <- numLeft + 1
+								}
+								if: n > 3 {
+									numLeft <- 1
+									limitLeft <- n - 2
+									while: { numLeft < limitLeft } do: {
+										numMid <- 1
+										limitMid <- n - (1 + numLeft)
+										while: { numMid < limitMid } do: {
+											numRight <- n - (1 + numLeft + numMid)
+											choicesRight <- (allOfSize: numRight inFold?: infold?)
+											choicesMid <- (allOfSize: numMid inFold?: infold?)
+											foreach: (allOfSize: numLeft inFold?: infold?) :idx leftExp {
+												foreach: choicesMid :idx midExp {
+													foreach: choicesRight :idx rightExp {
+														res append: (if0: leftExp then: midExp else: rightExp)
+													}
+												}
+											}
+											numMid <- numMid + 1
+										}
+										numLeft <- numLeft + 1
+									}
+									if: n > 4 && infold? = 0 {
+										numSeq <- 1
+										limitSeq <- n - 3
+										while: { numSeq < limitSeq } do: {
+											numFun <- 1
+											limitFun <- n - (2 + numSeq)
+											while: { numFun < limitFun } do: {
+												numStart <- n - (2 + numSeq + numFun)
+												choicesStart <- (allOfSize: numStart inFold?: 1)
+												choicesFun <- (allOfSize: numFun inFold?: 2)
+												foreach: (allOfSize: numSeq inFold?: 1) :idx seqExp {
+													foreach: choicesFun :idx funExp {
+														foreach: choicesStart :idx startExp {
+															res append: (fold: seqExp with: funExp startingAt: startExp)
+														}
+													}
+												}
+												numFun <- numFun + 1
+											}
+											numSeq <- numSeq + 1
+										}
+									}
+								}
+							}
+							print: "Saving " . (string: n) . " at memo index: " . (string: (memo length)) . "\n"
+							memo append: res
+							res
 						}
 					}
 				}
-			}
 
-			fold:with:startingAt <- :toFold :fun :startAcc {
-				#{
-					string <- {
-						"(fold " . (string: toFold) . " " . (string: startAcc) . " (lambda (val acc) " . (string: fun) . "))"
-					}
-					eval <- {
-						_acc <- (eval: startAcc)
-						source <- (eval: toFold)
-						//parser doesn''t currently like vertical whitespace in arays so
-						//this needs to be on a single line until that bug is fixed
-						vals <- #[source and 255u64 (rshift: source by: 8u64) and 255u64 (rshift: source by: 16u64) and 255u64 (rshift: source by: 24u64) and 255u64 (rshift: source by: 32u64) and 255u64 (rshift: source by: 40u64) and 255u64 (rshift: source by: 48u64) and 255u64 (rshift: source by: 56u64) and 255u64]
-						foreach: vals :idx cur {
-							_val <- cur
-							_acc <- (eval: fun)
-						}
-						_acc
-					}
-				}
-			}
-
-			run <- :in {
-				_input <- in
-				eval: root
-			}
-
-			root <- _zero
-
-			string <- {
-				"(lambda (input) " . (string: root) . ")"
-			}
-
-			gentestprog <- {
-				root <- if0: (opAnd: input one) then: (
-					plus: (opOr: input (shl1: one))
-				) else: (
-					opXor: input (shr16: input)
-				)
-				self
-			}
-
-			exampleprog <- {
-				root <- fold: input with: (opOr: val acc) startingAt: zero
-				self
-			}
-
-			//TODO: memoize this to improve runtime for large n
-			allOfSize:inFold? <- :n :infold? {
-				memo <- if: infold? = 2 {
-					_memoFoldBody
-				} else: {
-					if: infold? = 1 && n > 4 {
-						_memoFoldParam
-					} else: {
-						_memo
-					}
+				allOfSize <- :n {
+					allOfSize: (n - 1) inFold?: 0
 				}
-				if: n - 1 < (memo length) {
-					print: "Memo hit: " . (string: n) . "\n"
-					memo get: (n - 1)
-				} else: {
-					if: n = 1 {
-						res <- #[one zero input]
-						if: infold? = 2 {
-							res append: acc
-							res append: val
-						}
-						print: "Saving at memo index: " . (string: (memo length)) . "\n"
-						memo append: res
-						res
-					} else: {
-						res <- #[]
-						foreach: (allOfSize: n - 1 inFold?: infold?) :idx exp {
-							res append: (opNot: exp)
-							res append: (shl1: exp)
-							res append: (shr1: exp)
-							res append: (shr4: exp)
-							res append: (shr16: exp)
-						}
-						if: n > 2 {
-							numLeft <- 1
-							argTotal <- n - 1
-							while: { numLeft < argTotal } do: {
-								numRight <- argTotal - numLeft
-								choicesRight <- (allOfSize: numRight inFold?: infold?)
-								foreach: (allOfSize: numLeft inFold?: infold?) :idx leftExp {
-									foreach: choicesRight :idx rightExp {
-										res append: (opAnd: leftExp rightExp)
-										res append: (opOr: leftExp rightExp)
-										res append: (opXor: leftExp rightExp)
-										res append: (plus: leftExp rightExp)
-									}
-								}
-								numLeft <- numLeft + 1
-							}
-							if: n > 3 {
-								numLeft <- 1
-								limitLeft <- n - 2
-								while: { numLeft < limitLeft } do: {
-									numMid <- 1
-									limitMid <- n - (1 + numLeft)
-									while: { numMid < limitMid } do: {
-										numRight <- n - (1 + numLeft + numMid)
-										choicesRight <- (allOfSize: numRight inFold?: infold?)
-										choicesMid <- (allOfSize: numMid inFold?: infold?)
-										foreach: (allOfSize: numLeft inFold?: infold?) :idx leftExp {
-											foreach: choicesMid :idx midExp {
-												foreach: choicesRight :idx rightExp {
-													res append: (if0: leftExp then: midExp else: rightExp)
-												}
-											}
-										}
-										numMid <- numMid + 1
-									}
-									numLeft <- numLeft + 1
-								}
-								if: n > 4 && infold? = 0 {
-									numSeq <- 1
-									limitSeq <- n - 3
-									while: { numSeq < limitSeq } do: {
-										numFun <- 1
-										limitFun <- n - (2 + numSeq)
-										while: { numFun < limitFun } do: {
-											numStart <- n - (2 + numSeq + numFun)
-											choicesStart <- (allOfSize: numStart inFold?: 1)
-											choicesFun <- (allOfSize: numFun inFold?: 2)
-											foreach: (allOfSize: numSeq inFold?: 1) :idx seqExp {
-												foreach: choicesFun :idx funExp {
-													foreach: choicesStart :idx startExp {
-														res append: (fold: seqExp with: funExp startingAt: startExp)
-													}
-												}
-											}
-											numFun <- numFun + 1
-										}
-										numSeq <- numSeq + 1
-									}
+
+				filterTrees <- :trees strops {
+					filtered <- #[]
+					ops <- strops fold: 0 with: :acc el {
+						acc or (_names get: el withDefault: 0)
+					}
+					if: (ops and _opTfold) > 0 {
+						foreach: trees :idx tree {
+							if: (tree isTfold?) {
+								if: (tree operators) and _maskRemoveFold = ops and _maskRemoveFold {
+									filtered append: tree
 								}
 							}
 						}
-						print: "Saving " . (string: n) . " at memo index: " . (string: (memo length)) . "\n"
-						memo append: res
-						res
+					} else: {
+						foreach: trees :idx tree {
+							if: (tree operators) = ops {
+								filtered append: tree
+							}
+						}
 					}
+					filtered
 				}
 			}
+		}
 
-			allOfSize <- :n {
-				allOfSize: (n - 1) inFold?: 0
+		test <- :prog {
+			print: (string: prog) . "\n"
+			print: "Operators: " . (hex: ((prog root) operators)) . "\n"
+			if: ((prog root) isTfold?) {
+				print: "TFold!\n"
+			}
+			//parser doesn''t currently like vertical whitespace in arays so
+			//this needs to be on a single line until that bug is fixed
+			vals <- #[0u64 1u64 2u64 3u64 4u64 5u64 6u64 7u64 8u64 9u64 10u64 11u64 12u64 13u64 14u64 15u64 0x30001u64 0x50015u64 (lshift: 0x11223344u64 by: 32u64) or 0x55667788u64]
+			foreach: vals :idx val {
+				print: "p(0x" . (hex: val) . ") = 0x" . (hex: (prog run: val)) . "\n"
 			}
 		}
+
+		main <- :args {
+			//test: (program gentestprog)
+			//test: (program exampleprog)
+			size <- 3
+			if: (args length) > 1 {
+				size <- int32: (args get: 1)
+			}
+			if: size >= 2 {
+				prog <- program
+				trees <- (prog allOfSize: size)
+				if: (args length) > 2 {
+					ops <- (args get: 2) splitOn: ","
+					trees <- prog filterTrees: trees ops
+				}
+				foreach: trees :idx tree {
+					prog root! tree
+					test: prog
+				}
+			}
+			0
+		}
 	}
-
-	test <- :prog {
-		print: (string: prog) . "\n"
-		//parser doesn''t currently like vertical whitespace in arays so
-		//this needs to be on a single line until that bug is fixed
-		vals <- #[0u64 1u64 2u64 3u64 4u64 5u64 6u64 7u64 8u64 9u64 10u64 11u64 12u64 13u64 14u64 15u64 0x30001u64 0x50015u64 (lshift: 0x11223344u64 by: 32u64) or 0x55667788u64]
-		foreach: vals :idx val {
-			print: "p(0x" . (hex: val) . ") = 0x" . (hex: (prog run: val)) . "\n"
-		}
-	}
-
-	main <- :args {
-		test: (program gentestprog)
-		test: (program exampleprog)
-		size <- 3
-		if: (args length) > 1 {
-			size <- int32: (args get: 1)
-		}
-		if: size >= 2 {
-			prog <- program
-			foreach: (prog allOfSize: size) :idx tree {
-				prog root! tree
-				test: prog
-			}
-		}
-		0
-	}
 }