# PERL subset

p7source testing.p7i
p7source pair.p7i
p7source vec.p7i TYPE PerlShape
p7source vec.p7i TYPE PerlProduction
p7source vec.p7i TYPE PerlInst


set START	S

set GRAMMAR {

        S putchar       {E}     { printf "%d ", 255&($1); ++`numout; if (`numout>=256) {exit} }         {`:$1}
		{ }
        S putcharES     {E S}   { printf "%d ", 255&($1); ++`numout; if (`numout>=256) {exit}; $2 }     {``J`:$1$2}
		{ }
        S putcharSE     {S E}   { $1; printf "%d ", 255&($2); ++`numout; if (`numout>=256) {exit}; }    {``J$1`:$2}
		{ }

        S assign1       {V E}   { $1 = $2; }                    {`$1$2}
		{ }
        S assign2       {V E}   { $1 = $2; }                    {`$1$2}
		{ }
        S assign3       {V E}   { $1 = $2; }                    {`$1$2}
		{ }

        S while1        {E S}   { while ( 255&($1) ) { $2 } }         {```?$1`@``J$2$1@}
		{ }
        S while2        {E S}   { while ( 255&($1) ) { $2 } }         {```?$1`@``J$2$1@}
		{ }

        S if2           {E S}   { if (255&($1)) {$2} }                {```?$1${2}0}
		{ }
        S if3           {E S S} { if (255&($1)) {$2} else {$3} }              {```?$1$2$3}
		{ }
        S if3rev        {E S S} { if (!(255&($1))) {$2} else {$3} }           {```?$1$3$2}
		{ }

        S sequence1     {E S}   { $1 ; $2 }                     {``J$1$2}
		{ }
        S sequence2     {S E}   { $1 ; $2 }                     {``J$1$2}
		{ }
        S sequence3     {E S S} { $1 ; $2 ; $3 }                {``J``J$1$2$3}
		{ }
        S DefaultS         {}      { 0; }                          0
		{ }

	S incr		{V}	{ ++($1); }			{`$1`1$1}
		{ }
	S decr		{V}	{ --($1); }			{`$1`9$1}
		{ }
	S postincr	{V}	{ ($1)++; }			{`9`$1`1$1}
		{ }
	S postdecr	{V}	{ ($1)--; }			{`1`$1`9$1}
		{ }



	E DefaultE		{}	0				0
		{ }
	E 1		{}	1				1
		{ }
	E 2		{}	2				2
		{ }
	E 5		{}	5				`41
		{ }
	E 10		{}	10				`4`42
		{ }
	E neg1		{}	(-1)				`90
		{ }
	E neg2		{}	(-2)				`80
		{ }
	E neg5		{}	(-5)				`50
		{ }
	E var1		{V}	{ $1 }				{$1}
		{ }
	E var2		{V}	{ $1 }				{$1}
		{ }
	E var3		{V}	{ $1 }				{$1}
		{ }
	E var4		{V}	{ $1 }				{$1}
		{ }
	
	E add		{E E}	{( ($1) + ($2) )}		{``+$1$2}
		{ }
	E mul		{E E}	{( ($1) * ($2) )}		{``*$1$2}
		{ }
	E sub		{E E}	{( ($1) - ($2) )}		{``+$1`-$2}
		{ }
	E revsub	{E E}	{( ($2) - ($1) )}		{``+$2`-$1}
		{ }


	V DefaultV		{}	{ `a }				a
		{ }
	V b		{}	{ `b }				b
		{ }
	V c		{}	{ `c }				c
		{ }
	V d		{}	{ `d }				d
		{ }
	V e		{}	{ `e }				e
		{ }

}

#  slow_append, used n times,  is order n^2 but we only use it in initialization, and n is small

foreach TYPE { PerlProduction PerlShape } {eval [string map "TYPE $TYPE" {

	p7proc (TYPE*)slow_append<TYPE> { (TYPE*)array (TYPE)newItem } {
		new (TYPE*)z ( 1 + [len $array] )
		loop (int)i [len $array] { set z(i) $array(i) }
		set z(i) $newItem
		set z
	}
}]}

p7class PerlShape {   (tcl)letter   (PerlProduction*)choices  }

p7class PerlProduction {   (PerlShape)shape   (tcl)tag   (PerlShape*)params  (tcl)perlCode   (tcl)liCode  (tcl)func }



p7proc (PerlShape)GetShape { (tcl)letter } { 
	set (PerlShape)ps $ShapesDict($letter) 
	if ( ! ps )  {
		::puts stderr "NULL SHAPE FOR $letter"
	}
	set ps
}

p7global (dict)ShapesDict {
		new (dict)z
		foreach (tcl)s { S E V } {
			new (PerlShape)ps
			set ps(letter) $s
			set ps(choices) [new (PerlProduction*) 0]
			set z($s) $ps
		}
		set z
}

p7proc (PerlProduction)GetProduction { (tcl)tag } { return $NodesDict($tag) }

p7global (dict)NodesDict { new (dict) }

foreach {shapeLetter tag params perlCode liCode func} $GRAMMAR {

	# generate an INIT function for each tag

	p7proc (void)TAG_${tag}_INIT {} [
		list InitializeNode $shapeLetter $tag $params $perlCode $liCode $func
	]
}


p7proc (PerlShape*)ConvertTclStringsToShapes { (tcl)params } {

	# convert tcl string list "params" to PerlShape* params_vec:
	new (PerlShape*)params_vec [len $params]
	loop (int)i [len $params] { set params_vec($i) [GetShape $params($i)] }

	set params_vec
}

p7proc (void)InitializeNode {shapeLetter tag params perlCode liCode func} {

	set (PerlShape)shape [GetShape $shapeLetter]



	new (PerlProduction)prod		;# make a new PerlProduction
	set prod(shape)		$shape
	set prod(tag)		$tag
	set prod(params)		[ConvertTclStringsToShapes $params]
	set prod(perlCode)	$perlCode
	set prod(liCode)		$liCode
	set prod(func)		$func

	set NodesDict($tag) $prod		;# install the new PerlProduction

	set shape(choices) [slow_append<PerlProduction> (shape.choices) $prod]

}

p7proc (tcl)NodesWithSameShapeAndParams { (PerlShape)shape (PerlShape*)params } {

	set (tcl)z

	loop  (int)i  [len (shape.choices)]  {

		set (PerlProduction)prod (shape.choices($i))
		if ( [len $params] != [len (prod.params)] ) {continue}

		set (int)ok 1
		loop  (int)j  [len $params]  {
			if ( (params[$j]) != (prod.params[$j]) ) {set ok 0; continue}
		}
		if (ok) { lappend z $prod }
	}
	set z
}

p7test Shape_S_E_S { 
	new (PerlShape*)v 2
	set v(0) [GetShape "E"]
	set v(1) [GetShape "S"]

	
	return ( 5 == [len [ NodesWithSameShapeAndParams [GetShape "S"]  $v ] ] )
}


if [p7debug] {
  p7proc (void)dump_INIT {} {

	new (PerlShape*)v 2
	set v(0) [GetShape "E"]
	set v(1) [GetShape "S"]

	
	foreach (tcl)x [ NodesWithSameShapeAndParams [GetShape "S"]  $v ] {
		set (PerlProduction)y $x
		::puts stdout "node $x tag $y(tag) tag $x.tag"
	}
  }
  
}

p7class PerlInst {   (PerlProduction)cls  (PerlInst*)argv  }

p7class IntRef { (int)value }

p7proc (PerlInst)CompileListToInsts { (tcl)list } {
	new (IntRef)index
	set index(value) 0
	CompileListToInstsRecursively $list $index
}

p7proc (PerlInst)CompileListToInstsRecursively { (tcl)list (IntRef)index } {

	set (PerlProduction)node [ GetProduction $list(index.value) ]
	if ( ! node ) { error "cannot find PerlProduction named $list(index.value) " }

	incr index(value)

	new (PerlInst)z
	set z(cls) $node
	set z(argv) [new (PerlInst*) [len (node.params)]]
	set (int)j 0
	foreach (tcl)p (node.params) {

		set z(argv)($j) [ CompileListToInstsRecursively $list $index ]
		incr j
	}

	return $z
}

p7test CompileVar {
	set (PerlInst)x [ CompileListToInsts "b" ]
	k ( x.cls.shape.letter eq "V" )
}

p7test CompileAdd {
	set (PerlInst)x [ CompileListToInsts "add b c" ]
	if ( ! x ) { error "null x" }
	if ( x.cls.shape.letter ne "E" ) { error "x.cls.shape.letter not E" }
	if ( ! x.argv[0] ) { error "null x.argv\[0]" }
	if ( ! x.argv[1] ) { error "null x.argv\[1]" }
	if ( x.argv[0].cls.shape.letter ne "V" ) { error "x.argv\[0].cls.shape.letter not E" }
	if ( x.argv[1].cls.shape.letter ne "V" ) { error "x.argv\[1].cls.shape.letter not E" }
	return 1
}



#	
#	package require Tclx
#	proc Pl_MutateVec {vec} {
#	#puts "<<< $vec"
#	#  if [catch {
#		foreach try {once twice thrice} {
#			set r [RANDOM [llength $vec]]
#			set a [lindex $vec $r]
#			set sap "$::Shape($a),$::Params($a)"
#			set list $::SameShapeAndParams($sap)
#			set i [RANDOM [llength $list]]
#	#puts $i/[llength $list]/$a/$sap
#			set z [lreplace $vec $r $r [lindex $list $i]]
#			if { $z ne $vec } break ;# good, valid mutation
#		}
#	#  }] {
#	#puts ?$::errorInfo
#	#puts ?vec=$vec
#	#puts ?r=$r
#	#puts ?a=$a
#	#DEBUGGER
#	#  }
#	#puts ">>> $z"
#	  set z
#	}
#	
#	proc RANDOM n {expr {int( $n*rand() )}}
#	
#	proc Pl_LengthOfSubtree {vec start} {
#		set i $start
#		Pl_LengthOfSubtreeRecursive $vec i $::START
#		expr { $i - $start }
#	}
#	proc Pl_LengthOfSubtreeRecursive {vec iName type} {
#		upvar 1 $iName i
#	
#		if {$i >= [llength $vec]} {
#			set name Default$type
#		} else {
#			set name [lindex $vec $i]
#			incr i
#		}
#	
#		foreach p $::Params($name) {
#			Pl_LengthOfSubtreeRecursive $vec i $p
#		}
#	}
#	
#	proc plpickChosenShapeIndices {vec shape} {
#		set match {}
#		set i 0
#		foreach x $vec {
#			if { $::Shape($x) eq $shape } { lappend match $i }
#			incr i
#		}
#		set match
#	}
#	
#	proc pl-cross {v1 v2} {
#	#puts v1:$v1
#	#puts v2:$v2
#		set shapes [array names ::NamesForShape]
#		set r0 [RANDOM [llength $shapes]]
#		set chosen_shape [lindex $shapes $r0]
#	#puts cs:$chosen_shape
#		set ok1 [plpickChosenShapeIndices $v1 $chosen_shape ]
#	#puts ok1=$ok1
#		set ok2 [plpickChosenShapeIndices $v2 $chosen_shape ]
#	#puts ok2=$ok2
#	
#		if { ! [llength $ok1] || ! [llength $ok2] } { error CANNOT } ;# failure
#	
#		set r1 [RANDOM [llength $ok1]]
#		set i1 [lindex $ok1 $r1]
#		set r2 [RANDOM [llength $ok2]]
#		set i2 [lindex $ok2 $r2]
#	
#		set len1 [Pl_LengthOfSubtree $v1 $i1]
#		set len2 [Pl_LengthOfSubtree $v2 $i2]
#	
#	#puts i1len1=$i1/$len1
#	#puts i2len2=$i2/$len2
#		set z1 [concat [ 
#			lrange $v1 0 [expr {$i1-1}] ] [
#			lrange $v2 $i2 [expr {$i2+$len2-1}] ] [
#			lrange $v1 [expr {$i1+$len1}] end ] ]
#	
#		if {[llength $z1]>200} {
#			#puts "TRUNCATING [llength $z1] $z1"
#			set z1 [lrange $z1 0 200]  ;# truncate if too big
#		}
#		
#		set z2 [concat [ 
#			lrange $v2 0 [expr {$i2-1}] ] [
#			lrange $v1 $i1 [expr {$i1+$len1-1}] ] [
#			lrange $v2 [expr {$i2+$len2}] end ] ]
#	
#		if {[llength $z2]>200} {
#			#puts "TRUNCATING [llength $z2] $z2"
#			set z2 [lrange $z1 0 200]  ;# truncate if too big
#		}
#		
#		list $z1 $z2
#	}
#	
#	proc Pl_RandomlyProduceRecurse {vecName shape} {
#		upvar 1 $vecName vec
#	#puts "<<<< $shape <<<< $vec"
#		set names $::NamesForShape($shape)
#		set r [RANDOM [llength $names]]
#		set name [lindex $names $r]
#		lappend vec $name
#		foreach param $::Params($name) {
#			Pl_RandomlyProduceRecurse vec $param
#		}
#	#puts ">>>> $vec"
#	}
#	proc Pl_RandomlyProduce {shape} {
#		set vec {}
#		Pl_RandomlyProduceRecurse vec $shape
#		return $vec
#	}
#	
#	proc Lp_Decompile {vec} {
#		set i 0
#		set lith [Lp_DecompileRecursive $vec i $::START ]
#		set lith [string map { ` "(" } $lith]
#	}
#	
#	proc Lp_DecompileRecursive {vec iName type} {
#		upvar 1 $iName i
#	
#	
#		if {$i >= [llength $vec]} {
#			set name Default$type
#		} else {
#			set name [lindex $vec $i]
#		}
#		incr i
#		set j 1
#	
#		foreach p $::Params($name) {
#	
#			set "$j" [Lp_DecompileRecursive $vec i $p]
#	
#			incr j
#		}
#	
#		subst -nocommands -nobackslashes $::Lith($name)
#	}
#	proc Pl_Decompile {vec} {
#		set i 0
#		set code "`|=1; [Pl_DecompileRecursive $vec i $::START ]"
#		set code [string map { ` $ } $code]
#	}
#	
#	proc Pl_DecompileRecursive {vec iName type} {
#	if [string match *((* $vec] DEBUGGER
#		upvar 1 $iName i
#	
#		if {$i >= [llength $vec]} {
#			set name Default$type
#		} else {
#			set name [lindex $vec $i]
#		}
#		incr i
#		set j 1
#	
#		foreach p $::Params($name) {
#	
#			set "$j" [Pl_DecompileRecursive $vec i $p]
#	
#			incr j
#		}
#	
#		subst -nocommands -nobackslashes $::Code($name)
#	}
#	
#	proc pl-random-program {} {
#		set x [Pl_RandomlyProduce S]
#		return "$x\n---\n[Pl_Decompile $x]"
#	}
#	proc lp-random-program {} {
#		set x [Pl_RandomlyProduce S]
#		return "$x\n[Lp_Decompile $x]\n[Pl_Decompile $x]"
#	}
#	
#	proc pl-cross-programs {p1 p2} {
#	  set zz ""
#	
#		set pp [pl-cross $p1 $p2]
#	#puts "pl-cross-programs: pp=$pp"
#	
#		append y [lindex $pp 0]
#		append y \n---\n [Pl_Decompile $y] \n
#	
#		append z [lindex $pp 1]
#		append z \n---\n [Pl_Decompile $z] \n
#	
#		set zz [list $y $z]
#	
#	   set zz
#	}
#	
#	proc pl-mutate-program {vec numMutations} {
#		for {set i 0} {$i<$numMutations} {incr i} {
#			set newvec [ Pl_MutateVec $vec ]
#			if { ! [llength $newvec] } continue ;# ignore newvec if it is empty
#			set vec $newvec
#		}
#		append z $vec \n---\n [Pl_Decompile $vec] \n
#		set z
#	}
#	proc lp-mutate-program {vec numMutations} {
#	#puts "IN<<< $vec"
#		for {set i 0} {$i<$numMutations} {incr i} {
#			set vec [ Pl_MutateVec $vec ]
#		}
#		set z "$vec\n[Lp_Decompile $vec]\n[Pl_Decompile $vec]\n"
#	#puts "OUT>> $vec\n"
#		set z
#	}
#	proc lp-cross-programs {p1 p2} {
#	  set zz ""
#	
#		set pp [pl-cross $p1 $p2]
#	#puts "pl-cross-programs: pp=$pp"
#	
#		append y [lindex $pp 0]
#		append y \n [Lp_Decompile $y] \n [Pl_Decompile $y] \n
#	
#		append z [lindex $pp 1]
#		append z \n [Lp_Decompile $z] \n [Pl_Decompile $z] \n
#	
#		set zz [list $y $z]
#	
#	   set zz
#	}
#	
#	
#	
#	#end