view src/bv.tp @ 43:96b2fcb746bf

Add support for generating programs with only a certain set of operators to allow work with slightly larger problem sizes
author Mike Pavone <pavone@retrodev.com>
date Sun, 11 Aug 2013 02:16:14 -0700
parents b00904b36aca
children 0f8adc187d29 f864792a1b17
line wrap: on
line source

{
	#{
		program <- {
			_input <- 0u64
			_acc <- 0u64
			_val <- 0u64

			_zero <- #{
				string <- { "0" }
				eval <- { 0u64 }
				operators <- { 0 }
				isTfold? <- { false }
				isTerminal? <- { true }
				constant? <- { true }
			}
			_accInputNode <- _zero
			_foldInputNode <- _zero

			_one <- #{
				string <- { "1" }
				eval <- { 1u64 }
				operators <- { 0 }
				isTfold? <- { false }
				isTerminal? <- { true }
				constant? <- { true }
			}

			_inputNode <- #{
				string <- { "input" }
				eval <- { _input }
				operators <- { 0 }
				isTfold? <- { false }
				isTerminal? <- { true }
				constant? <- { false }
			}
			_accNode <- #{
				string <- { "acc" }
				eval <- { _acc }
				operators <- { 0 }
				isTfold? <- { false }
				isTerminal? <- { true }
				constant? <- { _accInputNode constant? }
			}
			_valNode <- #{
				string <- { "val" }
				eval <- { _val }
				operators <- { 0 }
				isTfold? <- { false }
				isTerminal? <- { true }
				constant? <- { _foldInputNode constant? }
			}
			_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 }
						constant? <- { (left constant?) && (right constant?) }
					}
				}
				zero <- {
					_zero
				}

				one <- {
					_one
				}

				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 }
						constant? <- {
							if: (left constant?) {
								if: (right constant?) {
									true
								} else: {
									if: (string: left) = "0" {
										true
									} else: {
										false
									}
								}
							} else: {
								if: (right constant?) {
									if: (string: right) = "0" {
										true
									} else: {
										false
									}
								} else: {
									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 }
						constant? <- { (left constant?) && (right constant?) }
					}
				}

				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 }
						constant? <- {
							if: (left constant?) && (right constant?) {
								true
							} else: {
								(string: left) = (string: right)
							}
						}
					}
				}

				opNot <- :exp {
					#{
						string <- { "(not " . (string: exp) . ")" }
						eval <- { (eval: exp) xor -1u64 }
						operators <- { _opNot or (exp operators)}
						isTfold? <- { false }
						isTerminal? <- { false }
						constant? <- { exp constant? }
					}
				}

				shl1 <- :exp {
					#{
						string <- { "(shl1 " . (string: exp) . ")" }
						eval <- { lshift: (eval: exp) by: 1u64 }
						operators <- { _opShl1 or (exp operators)}
						isTfold? <- { false }
						isTerminal? <- { false }
						constant? <- { exp constant? }
					}
				}

				shr1 <- :exp {
					#{
						string <- { "(shr1 " . (string: exp) . ")" }
						eval <- { rshift: (eval: exp) by: 1u64 }
						operators <- { _opShr1 or (exp operators)}
						isTfold? <- { false }
						isTerminal? <- { false }
						constant? <- { exp constant? }
					}
				}

				shr4 <- :exp {
					#{
						string <- { "(shr4 " . (string: exp) . ")" }
						eval <- { rshift: (eval: exp) by: 4u64 }
						operators <- { _opShr4 or (exp operators)}
						isTfold? <- { false }
						isTerminal? <- { false }
						constant? <- { exp constant? }
					}
				}

				shr16 <- :exp {
					#{
						string <- { "(shr16 " . (string: exp) . ")" }
						eval <- { rshift: (eval: exp) by: 16u64 }
						operators <- { _opShr16 or (exp operators)}
						isTfold? <- { false }
						isTerminal? <- { false }
						constant? <- { exp constant? }
					}
				}

				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
							} else: {
								eval: ifnotzero
							}
						}
						operators <- { _opIf0 or (exp operators) or (ifzero operators) or (ifnotzero operators)}
						isTfold? <- { false }
						isTerminal? <- { false }
						constant? <- { (exp constant?) && (ifzero constant?) && (ifnotzero constant?) }
					}
				}

				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 }
						constant? <- {
							_accInputNode <- startAcc
							_foldInputNode <- toFold
							fun constant?
						}
					}
				}

				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
						}
					}
					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
										}
									}
								}
							}
							print: "Saving " . (string: n) . " at memo index: " . (string: (memo length)) . "\n"
							memo append: res
							res
						}
					}
				}

				allOfSize <- :n {
					allOfSize: (n - 1) inFold?: 0
				}

				allOfSize:inFold?:withOps <- :n :infold? :ops {
					if: n = 1 {
						res <- #[one zero input]
						if: infold? = 2 {
							res append: acc
							res append: val
						}
						res
					} else: {
						res <- #[]
						origops <- ops
						if: (ops and _opTfold) > 0 {
							ops <- ops and _maskRemoveFold
						}
						if: (ops and (_opNot or _opShl1 or _opShr1 or _opShr4 or _opShr16)) > 0 {
							foreach: (allOfSize: n - 1 inFold?: infold? withOps: ops) :idx exp {
								if: (ops and _opNot) > 0 {
									res append: (opNot: exp)
								}
								if: (ops and _opShl1) > 0 {
									res append: (shl1: exp)
								}
								if: (ops and _opShr1) > 0 {
									res append: (shr1: exp)
								}
								if: (ops and _opShr4) > 0 {
									res append: (shr4: exp)
								}
								if: (ops and _opShr16) > 0 {
									res append: (shr16: exp)
								}
							}
						}
						if: n > 2 {
							numLeft <- 1
							argTotal <- n - 1
							if: (ops and (_opAnd or _opOr or _opXor or _opPlus)) > 0 {
								while: { numLeft < argTotal } do: {
									numRight <- argTotal - numLeft
									choicesRight <- (allOfSize: numRight inFold?: infold? withOps: ops)
									foreach: (allOfSize: numLeft inFold?: infold? withOps: ops) :idx leftExp {
										foreach: choicesRight :idx rightExp {
											if: (ops and _opAnd) > 0 {
												res append: (opAnd: leftExp rightExp)
											}
											if: (ops and _opOr) > 0 {
												res append: (opOr: leftExp rightExp)
											}
											if: (ops and _opXor) > 0 {
												res append: (opXor: leftExp rightExp)
											}
											if: (ops and _opPlus) > 0 {
												res append: (plus: leftExp rightExp)
											}
										}
									}
									numLeft <- numLeft + 1
								}
							}
							if: n > 3 {
								numLeft <- 1
								limitLeft <- n - 2
								if: (ops and _opIf0) > 0 {
									while: { numLeft < limitLeft } do: {
										numMid <- 1
										limitMid <- n - (1 + numLeft)
										while: { numMid < limitMid } do: {
											numRight <- n - (1 + numLeft + numMid)
											choicesRight <- (allOfSize: numRight inFold?: infold? withOps: ops)
											choicesMid <- (allOfSize: numMid inFold?: infold? withOps: ops)
											foreach: (allOfSize: numLeft inFold?: infold? withOps: ops ) :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 && (origops and (_opFold or _opTfold)) > 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 withOps: ops)
											choicesFun <- (allOfSize: numFun inFold?: 2 withOps: ops)
											foreach: (allOfSize: numSeq inFold?: 1 withOps: ops) :idx seqExp {
												foreach: choicesFun :idx funExp {
													foreach: choicesStart :idx startExp {
														if: (origops and _opFold) >  0 {
															res append: (fold: seqExp with: funExp startingAt: startExp)
														} else: {
															mtf <- fold: seqExp with: funExp startingAt: startExp
															if: (mtf isTfold?) {
																res append: mtf
															}
														}
													}
												}
											}
											numFun <- numFun + 1
										}
										numSeq <- numSeq + 1
									}
								}
							}
						}
						res
					}
				}

				allOfSize:withOps <- :size strops {
					ops <- strops fold: 0 with: :acc el {
						acc or (_names get: el withDefault: 0)
					}
					allOfSize: size inFold?: 0 withOps: ops
				}

				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
								}
							}
						}
					} else: {
						foreach: trees :idx tree {
							if: (tree operators) = ops {
								filtered append: tree
							}
						}
					}
					filtered
				}
			}
		}

		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 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
				ops <- #[]
				if: (args length) > 2 {
					ops <- (args get: 2) splitOn: ","
				}
				trees <- #[]
				if: (ops length) > 0 {
					if: size < 9 {
						trees <- (prog allOfSize: size)
						trees <- prog filterTrees: trees ops
					} else: {
						trees <- (prog allOfSize: size withOps: ops)
					}
				} else: {
					trees <- (prog allOfSize: size)
				}
				foreach: trees :idx tree {
					prog root! tree
					test: prog
				}
			}
			0
		}
	}
}