#!/bin/sh
# \
exec tclsh $0 $*
#
#
# Read Pads Part definitions
# PCB
#

source geom.tcl

proc processplist  { pat } {
	global argv id layer width
	global Objects texttype linetype
	global f sub

	set DLIST {}
  set PARTS [list]
  while { ! [eof $f] } {
	set name ""
	set text 0
	set npads 0
	set npins 0
	set cpins 0
	set sigpins 0
	set gnum 0

	set head [gets $f]
	scan $head "%s %s %s %s %d %d %d %d %d %d" name decals type family text gnum sigpins alpha flags  cpins 
	if { $name == "" } {continue  }

	regsub -all {[\\]} $name "-" name
	regsub -all {[/]} $name "-" name

	regsub -all {[\\]} $decals "-" decals
	regsub -all {[/]} $decals "-" decals
	if { [regexp -- $pat $name] == 0 } { skiptonext ; continue }

	#lappend PARTS "$name D:$decals F:$family G:$gnum T:$text"
	lappend PARTS "$name"
 }
  puts $PARTS
}

proc processpart  { pat } {
	global argv id layer width
	global Objects texttype linetype
	global f sub

	set DLIST {}

  while { ! [eof $f] } {
	set name ""
	set text 0
	set npads 0
	set npins 0
	set cpins 0
	set sigpins 0
	set gnum 0

	set head [gets $f]
	scan $head "%s %s %s %s %d %d %d %d %d %d" name decals type family text gnum sigpins alpha flags  cpins 
	if { $name == "" } {continue  }

	regsub -all {[\\]} $name "-" name
	regsub -all {[/]} $name "-" name

	regsub -all {[\\]} $decals "-" decals
	regsub -all {[/]} $decals "-" decals

	if { [regexp -- $pat $name] == 0 } { skiptonext ; continue }

	#puts "$head"
	#puts "$name D:$decals F:$family G:$gnum T:$text"

	set f2 [open Library/$sub/$name.p w]

	set ty Part

	puts $f2 "Part,Name $name"
	puts $f2 "Part,Class $family"
	puts $f2 "Part,Prefix [partPrefix $family]"
	puts $f2 "Part,Decals [list [split $decals :]]"
	puts $f2 "Part,ConPins $cpins"
	puts $f2 "Part,NumGates $gnum"
	puts $f2 "Part,SigPins [list $sigpins]"
	set DLIST [join $decals]
	while { $text } {
		puts  $f2 "Part,Text,$text [list [gets $f]]"
		incr text -1
	}
	set gatepins ""
	set visuals ""
	set vlist ""
	while { $gnum } {
		scan [gets $f] "%s %s %d" gd gswap pins
		set visuals [lrange [split $gd :] 1 end]
		regsub -all {[\\]} $visuals - visuals
		regsub -all {[/]} $visuals - visuals
		set gpin ""
		while { $pins > 0 } {
			foreach p [split [string trim [gets $f]]]  {
				set xx [split $p .]
				set pin  [lindex $xx 0]
				set pn [lindex $xx 3]
				regsub {[\\]} $pn "~" pn
				set suf [lindex $xx 4]
				if { $suf != "" } { set pn "$pn.$suf" }
				lappend gpin [list $pin $pn]
			}
			incr pins -3
		}
		lappend gatepins $gpin
		lappend DLIST [join $visuals]
		lappend vlist $visuals
		incr gnum -1
	}
	puts $f2 "Part,Gates [list $vlist]"
	puts $f2 "Part,GatePins [list $gatepins]"

	set sigs ""
	while { $sigpins } {
		lappend sigs [gets $f]
		incr sigpins -1
	}
	puts $f2 "Part,SigPins $sigs"
	set apins ""
	while { $alpha } {
		lappend apins [gets $f]
		incr alpha -1
	}
	puts $f2 "Part,AlphaPins $apins"
		
	close $f2
  }
 puts [join $DLIST]
}

proc processdecal  { pat } {
	global argv id layer width
	global Objects texttype linetype
	global f 

  while { ! [eof $f] } {
	set head [gets $f]
	set name ""
	set ntext 0
	set npads 0
	set npins 0
	scan $head "%s %s %d %d %d %d %d %d %d %d %d" name xx orix oriy refx refy refrot nobjs npins npads ntext
	if { $name == "" } {continue }

	regsub -all {[\\]} $name "-" name
	regsub -all {[/]} $name "-" name

	if { [regexp $pat $name] == 0 } { skiptonext ; continue }
	set Objects {}
	puts "$name @$orix,$oriy: O:$nobjs T:$npins P:$npads T:$ntext"

	set layer Bottom
	set texttype Copper
	set linetype Outline
	set id 1
	lappend Objects [list text [list $refx $refy] "ID($id)  Type(RefDes) Layer(All) " "-text RefDes -anc c"]
	incr id
	#lappend Objects [list text [list $refx [expr $refy + 30]] "ID($id)  Type(PartRef) Layer(All) " "-text PartRef -anc c"]
	#incr id

	process $name d $orix $oriy $nobjs $npads $npins $ntext
 
  }

}

proc processline  { pat } {
	global argv id layer width
	global Objects texttype linetype
	global f 

  while { ! [eof $f] } {
	set name ""
	set ntext 0
	set npads 0
	set npins 0
	set nobjs 0
	set head [gets $f]
	regsub -all "\t" $head " " head
	
	scan $head "%s %s %s %d %d %d %d" name type lay orix oriy nobjs ntext
	if { $name == "" } {continue }

	regsub -all {[\\]} $name "-" name
	regsub -all {[/]} $name "-" name

	if { [regexp $pat $name] == 0 } { skiptonext ; continue }
	set Objects {}
	puts "$name @ $orix,$oriy: O:$nobjs T:$npins P:$npads T:$ntext"

	set layer All
	set texttype Decor
	set linetype Decor
	set id 1

	process $name v $orix $oriy $nobjs $npads $npins $ntext
 
  }

}


proc processcaedecal  { pat } {
	global argv id layer width
	global Objects texttype linetype
	global f 

  while { ! [eof $f] } {

	set name ""
	set head [gets $f]
	set ntext 0
	set npads 0
	set npins 0
	set nobjs 0
	scan $head "%s %d %d %d %d %d" name orix oriy nobjs npins ntext
	if { $name == "" } {continue }
	regsub -all {[\\]} $name "-" name
	regsub -all {[/]} $name "-" name
	if { [regexp $pat $name] == 0 } { skiptonext; continue }

	set h1 [gets $f]
	set h2 [gets $f]
	scan $h1 "%d %d %d %d %d %d %d %d" rdx rdy rdo rdj ptx pty pto ptj
	scan $h2 "%d %d %d %d %d %d %d %d" vlx vly vlo vlj tlx tly tlo tlj
	set rdy [expr -$rdy]
	set pty [expr -$rdy]
	set tly [expr -$rdy]
	set vly [expr -$rdy]


	puts "$name @ $orix,$oriy: O:$nobjs T:$npins P:$npads T:$ntext"

	set layer All
	set texttype Outline
	set linetype Outline
	set Objects {}
	set id 1
	lappend Objects [list text [list $rdx $rdy] "ID($id)  Type(RefDes) Layer(All) " "-text RefDes -anc c"]
	incr id
	lappend Objects [list text [list $ptx $pty] "ID($id)  Type(PartRef) Layer(All) " "-text PartRef -anc c"]
	incr id
	process $name v $orix $oriy $nobjs $npads $npins $ntext
 
  }

}

proc skiptonext {} {
	global f

	while { ! [eof $f] && [set x [gets $f]] != "" } {
	}
	return
}


proc process {name pty orix oriy nobjs npads npins ntext} {

	global f id width layer Objects sub
	global texttype linetype 

	while { $nobjs > 0} {
		set l [gets $f]

		set func ""
		set side Bottom
		set lay ""
		scan $l "%s %d %d %d" func n w lay
		if { $func == "" } { continue }
		set vl ""
		#puts "Obj: :$func: $n $w $side"
		if { $lay == "" } {set side $layer }
		#if { $lay == -1 } { set side Internal }
		if { $lay == 0 } { set side Bottom }
		#if { $lay == -2 } { set side Top }
		if { $lay == 1 } { set side Top }
		if { $lay == 2 } { set side Bottom }

		#puts "Obj: :$func: $n $w $side"
		while { $n > 0 } {
			set bga 0
			set lea 0
			set x1 0
			set x2 0
			set y1 0
			set y2 0
			scan [gets $f] "%d %d %d %d %d %d %d %d %d" x y bga lea xxx x1 y1 x2 y2
			set y [expr -$y]
			if { $bga != 0 } {
				doArc $x $y $bga $lea $x1 $y1 $x2 $y2
				lappend vl $x $y
				#gets $f
			} else {
				lappend vl $x $y
			}
			incr n -1
		}
		regsub -all "\t" $vl " " vl
		if { [llength $vl] < 4 } { incr nobjs -1 ; continue }
		set itemlayer $layer
		set type ""
		set opt ""
		set ptype $linetype
		set width $w
		switch $func {
			OPEN {
				set type "line"
				set opt ""
				}

			CLOSED {
				set type "line"
				set opt "Filled"
				}

			CIRCLE {
				set type "oval"
				set opt ""
				set vl [mkbb $vl]
				}

			COPCLS {
				set type  "polygon"
				set ptype "Copper"
				set opt "Filled"
				}
			COPOPN {
				set type  "line"
				set opt ""
				#set vl [mkbb $vl]
				set ptype "Copper"
				set itemlayer $side
				}
			default {
				puts "Unknown object $func"
			}
		}
		incr nobjs -1
		if { $type == "" } { puts "Unknown Object $func" ; continue }
		lappend Objects [list $type $vl [list ID($id) Type($ptype) Layer($itemlayer) Width($width)] $opt ]
		incr id
	}
	while { $ntext  > 0} {
		scan [gets $f] "%d %d %d %d %d %d" x y t1 t2 th tw
		set y [expr -$y]
		set t [gets $f]
		lappend Objects [list text [list $x $y] [list ID($id) Type($texttype) Layer(All)] [list -text [list $t]] ]
		incr ntext -1
		incr id
	}
#	puts "NPins $npins"
	set Terminal {{}}
	set Pin $npins
	set term 1
	while { $npins  > 0} {
		set t [gets $f]
		set pin ""
		set namx 0
		set namy 0
		set numy 0
		set numx 0
		scan [string range $t 1 end] "%d %d %d %d %d %d %d %s" x y numx numy namx namy flags pin
		set y [expr -$y]
		set numx [expr 1 * $numx]
		set numy [expr 1 * -$numy]
		set namx [expr 1 * $namx]
		set namy [expr 1 * -$namy]
		lappend Terminal [list $x $y]
		if { $pty == "v" } {
			set p [gets $f]
			#puts "T$term: $t"
			set x1 [expr $x - 10]
			set y1 [expr $y - 10]
			set x2 [expr $x + 10]
			set y2 [expr $y + 10]
			lappend Objects [list oval [geomSquare 10 $x $y] "ID($id) Type(Anchor) Layer(All) PinType($pin) Pin($term) Heir(PIN$term) Filled" {}]
			# make both pin number and name same anchor so rotate tracks correctly
			lappend Objects [list text [pinT $flags $x $y [list [expr $x + $numx] [expr $y + $numy]]] [list ID($id) Type(Pin) Layer(All) PinNum($term)  Heir(PIN$term)] "-text $term -anchor [ancT $flags 5]" ]
			lappend Objects [list text [pinT $flags $x $y [list [expr $x + $namx] [expr $y + $namy]]] [list ID($id) Type(Pin) Layer(All) PinName($term) Heir(PIN$term)] "-text #$term -anchor [ancT $flags 6]" ]
			doPin $pin $x $y $flags $term
			incr term
			incr id
			doP $p 
		}
		incr npins -1
	}
#	puts "NPads $npads"
	set Pads {}
	while { $npads > 0 } {
		set p1 [gets $f]
		set nlay 0
		set pnum 0
		scan $p1 "%s %d %d" x pnum nlay
		set lay {}
		while { $nlay > 0} {
			set p2 [gets $f]
			lappend lay $p2
			incr nlay -1
		}
		lappend Pads [list $pnum [list $lay]]
		incr npads -1
	}

	set pin $Pin
	set Pmaxx  -10000000
	set Pminx  1000000000
	set Pmaxy  -10000000
	set Pminy  1000000000
	set term 1
	while { $pin > 0 } {
		scan  [lindex $Terminal $pin] "%d %d" x y
		if { $x > $Pmaxx } { set Pmaxx $x}
		if { $x < $Pminx } { set Pminx $x}
		if { $y > $Pmaxy } { set Pmaxy $y}
		if { $y < $Pminy } { set Pminy $y}
		set s [lsearch -regex $Pads "^$pin "]
		if { $s == -1 } {
			set s [lsearch -regex $Pads "^0 "]
		}
		set pd [lindex $Pads $s]
####
### Need to do all layers don't we ???
####
		doPad $term $x $y [lindex $pd 1]
		incr term
		incr pin -1
	}
	#	set Pminx [geomClip $Step $Pminx]
	#	set Pmaxx [geomClip $Step $Pmaxx]
	#	set Pminy [geomClip $Step $Pminy]
	#	set Pmaxy [geomClip $Step $Pmaxy]

	set maxx  -10000000
	set minx  1000000000
	set maxy  -10000000
	set miny  1000000000
	foreach o $Objects {
		foreach {x y} [lindex $o 1] {
			if { $x > $maxx } { set maxx $x}
			if { $x < $minx } { set minx $x}
			if { $y > $maxy } { set maxy $y}
			if { $y < $miny } { set miny $y}
		}
	}

	if { $Pin == 0 } {
		set Pmaxx  $maxx
		set Pminx  $minx
		set Pmaxy  $maxy
		set Pminy  $miny
		puts "no pins $minx - $maxx , $miny - $maxy"
	}

	set Step 25
	set minx [geomClip $Step $minx]
	set maxx [geomClip $Step $maxx]
	set miny [geomClip $Step $miny]
	set maxy [geomClip $Step $maxy]

	set f2 [open Library/$sub/$name.$pty w]

	set ty Decal
	if { $pty == "v" } { set ty Visual}

	puts $f2 "$ty  $name PADS-PCB 1 \{$Pminx $Pminy $Pmaxx $Pmaxy\} \{\}"
	#puts "Shift  $Pminx $Pminy"
	foreach o $Objects  {
			set co  [lindex $o 1]
			set co [geomShift -$Pminx -$Pminy $co]
			puts $f2 "canvas [lindex $o 0] [list $co] [list [lindex $o 2]] [list [lindex $o 3]]"
	}
	close $f2

}

proc doArc {x y bea lea x1 y1 x2 y2} {
	global Objects id

	set y1 [expr -$y1]
	set y2 [expr -$y2]

	set st [expr   $bea / 10.0]
	set len [expr $lea / 10.0]
	set en [expr $len  ]
#	set en [expr 180 + 2 * (90 -$st)]

#	puts "arc $st:$len $en $bea $lea, $x1 $y1   $x2  $y2"
	lappend Objects [list arc [list $x1 $y1 $x2 $y2] "ID($id) Layer(All) Type(Outline)" "-start $st -extent $en -type arc"]
	incr id
}

proc ancT { flag bit } {

	set tr [expr ($flag & 4) >> 2][expr ($flag & 1)]

	switch $tr {
		00	{ return e }
		01	{ return s }
		10	{ return nw }
		11	{ return n }
	}
	puts "Anchor Error"

	if { [expr $flag &2] } {
		if { [expr $flag & (1 << $bit)] } {
			return "w"
		} else {
			return "e"
		}
	} 
	if { [expr $flag & (1 << $bit)] } {
		return "e"
	} else {
		return "w"
	}
}

proc doPad { term x y laylist } {
	global id

	global Objects

	set size 0
	set ori 0
	set length 0
	set hole 0
	set offset 0
	foreach l $laylist {
		scan [string range $l 1 end] "%d %d %s %d %d %d %d " lay size ptype ori length offset hole
		if { $size == 0 } { continue }
		set dx [expr $size / 2]
		set dy [expr $size / 2]
		set x1 [expr $x - $dx]
		set y1 [expr $y - $dy]
		set x2 [expr $x + $dx]
		set y2 [expr $y + $dy]
		set type rectangle
		if { $ptype == "R" } {set type oval }
		if { $ptype == "RF" } {
			set type rectangle
			set x1 [expr $x - [expr $length / 2] + $offset]
			set y1 [expr $y - $dy + $offset]
			set x2 [expr $x1 + $length]
			set y2 [expr $y1 + $size]
			if { $ori == 90 } {
			   scan [geomRotateBack $x $y $x1 $y1 $x2 $y2] "%d %d %d %d" x1 y1 x2 y2
			}
		 }
		if {$lay == -2 } {set lay Top}
		if {$lay == -1 } {set lay Intermal}
		if {$lay == 0 } {set lay Bottom}

		lappend Objects [list oval [geomSquare 10 $x $y] "ID($id) Type(Anchor) Layer(All) PinType(PAD) Pin($term) Heir(PAD$term) Filled" {}]
		lappend Objects [list $type [list $x1 $y1 $x2 $y2] [list ID($id) Type(Pad) Layer($lay) Hole($hole) Heir(PAD$term) Filled] {} ]
		lappend Objects [list text [list $x $y ]  [list ID($id) Type(Pin) Layer(All) PinNum($term) Heir(PAD$term)] "-text $term -anchor sw" ]
		incr id
	}
}


proc mkbb { vl } {

	scan $vl "%d %d %d %d" x1 y1 x2 y2

	set dx [expr $x2 - $x1]
	set dy [expr $y2 - $y1]
	if { $dx != 0 } {
		lappend bb $x1
		lappend bb [expr $y1 - $dx / 2]
		lappend bb $x2
		lappend bb [expr $y1 + $dx / 2]
	} else {
		lappend bb [expr $x1 - $dy / 2]
		lappend bb $y1
		lappend bb [expr $x1 + $dy / 2]
		lappend bb $y2
	}

	return $bb
}


proc doPin {p x y r n} {
	global id 
	global Objects
	set pl 100
	set b  25
	set ps 50
	switch $p {
		PIN {
			set x1 [expr $x + $pl]
			mkPin $n line [pinT $r $x $y [list $x $y $x1 $y]]
		}
		PINB {
			set x1 [expr $x + $pl - $b]
			mkPin $n line [pinT $r $x $y [list $x $y $x1 $y]]
			set y1 [expr $y - $b / 2]
			set y2 [expr $y + $b / 2]
			set x2 [expr $x + $pl ]
			mkPin $n oval [pinT $r $x $y [list $x1 $y1 $x2 $y2]]
		}
		PINCLK {
			set x1 [expr $x + $pl]
			mkPin $n line [pinT $r $x $y [list $x $y $x1 $y ]]
			set x2 [expr $x1 + $b]
			set y1 [expr $y - $b ]
			set y2 [expr $y + $b]
			set x2 [expr $x + $pl + $b]
			mkPin $n line [pinT $r $x $y [list  $x1 $y1 $x2 $y  $x1 $y2 $x1 $y1]]
		}
		PINCLKB {
			set x1 [expr $x + $pl - $b]
			mkPin $n line [pinT $r $x $y [list  $x $y $x1 $y]]
			set y1 [expr $y - $b]
			set y2 [expr $y + $b]
			set x2 [expr $x + $pl ]
			mkPin $n oval [list$x1 $y1 $x2 $y2  ]
			set x2 [[expr $x + $pl + $b ]
			mkPin $n line [pinT $r $x $y [list  $x $y1 $x2 $y  $x $y2 $x $y1]]
		}
		PINIEB {
			set x1 [expr $x + $pl ]
			mkPin $n line [pinT $r $x $y [list  $x $y $x1 $y]]
			set y1 [expr $y - $b]
			set x2 [expr $x + $pl  - $b]
			mkPin $n line [list $x $y $x2 $y2  $x2 $y ]
		}
		PINORB {
			set x1 [expr $x + $pl  ]
			mkPin $n line [pinT $r $x $y [list $x $y $x1 $y  ]]
			set x1 [expr $x + $pl - $b ]
			set y1 [expr $y - $b]
			set y2 [expr $y + $b]
			set x2 [expr $x + $pl + $b ]
			mkPin $n oval [pinT $r $x $y [list $x1 $y1 $x2 $y2]]
		}
		PINSHORT -
		PINSHRT {
			set x1 [expr $x + $ps  ]
			mkPin $n line  [pinT $r $x $y [list $x $y $x1 $y]]
		}
		PINVSHORT -
		PINVRTS -
		PINVSHRT {
			set y1 [expr $y + $ps  ]
			mkPin $n line [pinT $r $x $y [list $x $y $x $y1]]
		}
		default {
			puts "unknown pin type $p"
#			set x1 [expr $x + $pl]
#			mkPin $n line [pinT $r $x $y [list $x $y $x1 $y]]
		}
	}
}

proc mkPin {n ty coords} {
	global Objects
	global id

	lappend Objects [list $ty $coords [list ID($id) Type(Pin) Heir(PIN$n) Filled] {}]
}

proc pinT { r ox oy coords } {

	set t [expr $r & 1]
	if { $t } {
		set coords [geomRotate $ox $oy $coords]
	}
	set t [expr $r & 2]
	if { $t } {
		set coords [geomMirrorX $ox $oy $coords]
	}
	set t [expr $r & 4]
	if { $t } {
		set coords [geomMirrorY $ox $oy $coords]
	}
	#puts "Pin $coords"
	return $coords
}

proc doP { l } {
	global id

	#puts "P:$l"

}

proc doT { l } {
	global id Objects

}


proc partPrefix {fam} {

	if { $fam == "RES" } { return  R}
	if { $fam == "DIG" } { return U}
	if { $fam == "DRV" } { return U}
	if { $fam == "TTL" } { return U}
	if { $fam == "CMO" } { return U}
	if { $fam == "ECL" } { return U}
	if { $fam == "ANA" } { return U}
	if { $fam == "LIN" } { return U}
	if { $fam == "CAP" } { return C}
	if { $fam == "DIO" } { return D}
	if { $fam == "ZEN" } { return Z}
	if { $fam == "TRX" } { return Q}
	if { $fam == "XFR" } { return T}
	if { $fam == "CHO" } { return L}
	if { $fam == "IND" } { return L}
	if { $fam == "CON" } { return J}
	if { $fam == "RLY" } { return RL}
	if { $fam == "SCR" } { return TH}
	if { $fam == "TRC" } { return TH}
	if { $fam == "SWI" } { return SW}
	if { $fam == "MEC" } { return SW}
	if { $fam == "FUS" } { return F}
	if { $fam == "ASC" } { return I$}
	if { $fam == "TP" } { return  TP}
	if { $fam == "JUM" } { return  JP}
	if { [string length $fam] > 1} { return X}
	return $fam

}


set id 1
set layer 1
set width 10
set ty [lindex $argv 0]

set ext ""
switch $ty {
	part { set ext p }
	line { set ext l }
	decal { set ext d }
	caedecal { set ext c}
	plist {set ext p}
}

if { $ext == "" } {
	puts "syntax: rPads type file subdir pattern"
	puts "type is one of: part line decal caedecal"
	puts "pattern is regexp of items to process"
	exit
}

set sub [lindex $argv 2]
if { $sub == "" } {
	puts "Specify Library subdirectory"
	exit
}
set pat [lrange $argv 3 end]
if { $pat == "" } { set pat ".*" }
#set pat "$pat "
if { [llength $pat] > 1 }  {
	set pat "^[join $pat $|^]$"
} else {
	set pat [join $pat]
}

set file [file rootname [lindex $argv 1]]
if {! [file exists $file.$ext] } {exit}
set f [open $file.$ext r]

#puts "process $ty with $pat"
process$ty $pat

close $f


exit

