One more check on valid display which is known to be in the startup

[xcircuit.git] / lib / tcl / sue_xc.tcl

#------------------------------------------
# sue_xc.tcl
#------------------------------------------
# This script should be sourced into
# XCircuit and provides the capability to 
# translate .sue files into XCircuit
# schematics.  This script works properly
# with XCircuit version 3.10.21 or newer.
#------------------------------------------
# The primary routine is "make_all_sue",
# which is a TCL procedure to be run from
# the XCircuit command line in the directory
# containing .sue format files.  Without
# options, it creates a single XCircuit
# PostScript output file "sue_gates.ps",
# containing all of the gate symbols and
# associated schematics in a single file.
#------------------------------------------
# Written by R. Timothy Edwards
# 8/23/04
# MultiGiG, Inc.
# Scotts Valley, CA
# Updated 4/17/2020:  Stopped hard-coding the primitive
# devices in favor of making a "sue.lps" library.
#------------------------------------------------------------

global xscale
global sscale
# sue puts things on grids of 10, xcircuit on grids of 16.
set xscale 16
set sscale 10

#------------------------------------------------------------
# scale an {x y} list value from SUE units to XCircuit units
#------------------------------------------------------------

proc scale_coord {coord} {
   global xscale
   global sscale
   set x [lindex $coord 0]
   set y [lindex $coord 1]
   set x2 [expr {int(($x * $xscale) / $sscale)}]
   set y2 [expr {int((-$y * $xscale) / $sscale)}]
   set newc [lreplace $coord 0 1 $x2 $y2]
   return $newc
}

namespace eval sue {
    namespace export make make_wire make_line make_text

    #------------------------------------------------------------
    # make and make_wire: create the schematic elements
    #------------------------------------------------------------

    proc make {type args} {

        if {[llength $args] == 1} {
            set args [lindex $args 0]
        }

        # Default values
        # Note that the inverted Y axis reverses the meaning of Y in the
        # orientations.

        set flipped {}
        set angle 0 
        set width 1
        set length 1
        set name bad_element
        set origin {0 0}
        set instance_params {}

        foreach {key value} $args {
            switch -- $key {
                -orient {
                    switch -- $value {
                        RXY {
                            set angle 180
                        }
                        RX {
                            set flipped horizontal
                        }
                        RY {
                            set flipped vertical
                            set angle 180
                        }
                        R270 {
                            set angle 270
                        }
                        R90 {
                            set angle 90
                        }
                        R0 {
                            # defaults
                            set flipped {}
                            set angle 0
                        }
                    }
                }
                -origin {
                    set origin $value
                }
                -name {
                    set name $value
                }
                -text {
                    set name $value
                }
                default {
                    lappend instance_params [list [string range $key 1 end] $value]
                }
            }
        }

        set origin [scale_coord $origin]

        switch -- $type {
            input -
            output -
            inout -
            name_net -
            name_net_s {
                set newtext [label make pin $name $origin]
                rotate $newtext $angle $origin
                if {$flipped != {}} {
                    flip $newtext $flipped $origin
                }
            }

            global {
                set newtext [label make global $name $origin]
                rotate $newtext $angle $origin
                if {$flipped != {}} {
                    flip $newtext $flipped $origin
                }
            }

            text {
                set newtext [list $name]
                while {[set rp [string first \n $newtext]] >= 0} {
                    set newtext [string replace $newtext $rp $rp "\} \{return\} \{"]
                    set rp [string first \n $newtext]
                }
                set newtext [label make normal $newtext $origin]
                rotate $newtext $angle $origin
                if {$flipped != {}} {
                    flip $newtext $flipped $origin
                }
            }

            # Default behavior is to generate an object instance of the
            # given name.  This assumes that these are only objects that
            # have been defined in .sue files already.

            default {
                set newgate [instance make $type $origin]
                select $newgate
                rotate $angle $origin
                if {$flipped != {}} {
                    select $newgate
                    flip $flipped $origin
                }
                if {$instance_params != {}} {
                    select $newgate
                    foreach pair $instance_params {
                        set key [lindex $pair 0]
                        set value [lindex $pair 1]
                        parameter set $key $value -forward
                    }
                    deselect selected
                }
            }
        }
        deselect selected
    }

    #------------------------------------------------------------
    # Draw text on the schematic
    #------------------------------------------------------------

    proc make_text {args} {
        make text $args
    }

    #------------------------------------------------------------
    # Draw a wire into the schematic
    #------------------------------------------------------------

    proc make_wire {x1 y1 x2 y2} {
        # Scale the origin from SUE units to XCircuit units
        set s1 [scale_coord [list $x1 $y1]]
        set s2 [scale_coord [list $x2 $y2]]
        polygon make 2 $s1 $s2
    }

    proc make_line {args} {
        eval "make_wire $args"
    }
}

#------------------------------------------------------------
# icon_*: create the symbol
#------------------------------------------------------------

#------------------------------------------------------------
# default parameters (deferred)
#------------------------------------------------------------

proc icon_setup {icon_args params} {
    puts stdout "icon_setup $icon_args $params"

    foreach pair $params {
        set key [lindex $pair 0]
        set value [lindex $pair 1]
        if {$value == {}} {set value ""}
        switch -- $key {
            origin -
            orient {
                # Do nothing for now.  These are library instance values
                # in xcircuit, and could be set as such.
            }
            default {
                parameter make substring $key [list [list Text $value]]
            }
        }
    }
}

#------------------------------------------------------------
# pins
#------------------------------------------------------------

proc icon_term {args} {
    puts stdout "icon_term $args"
    set pintype "no_pin"
    set origin {0 0}
    set name "bad_pin_name"

    foreach {key value} $args {
        switch -- $key {
            -type {
                set pintype $value
            }
            -origin {
                set origin $value
            }
            -name {
                set name $value
            }
        }
    }
    set newtext [label make pin $name [scale_coord $origin]]
    label $newtext anchor center
    label $newtext anchor middle
    deselect selected
}

#------------------------------------------------------------
# instance parameters and symbol text labels
#------------------------------------------------------------

proc icon_property {args} {

    puts stdout "icon_property $args"

    set name {}
    set origin {0 0}
    set proptype {}
    set lscale 0.7

    foreach {key value} $args {

        switch -- $key {
            -origin {
                set origin $value
            }
            -name {
                set lhandle [label make normal [list [list Parameter $value]] [scale_coord $origin]]
                label $lhandle anchor center
                label $lhandle anchor middle
                label $lhandle scale $lscale
                deselect selected
            }
            -type {
                set proptype $value
            }
            -size {
                # label size.  Ignore, for now.
                switch -- $value {
                    -small {
                        set lscale 0.5
                    }
                    -large {
                        set lscale 0.9
                    }
                    default {
                        set lscale 0.7
                    }
                }
            }
            -label {
                set lhandle [label make normal "$value" [scale_coord $origin]]
                label $lhandle anchor center
                label $lhandle anchor middle
                label $lhandle scale $lscale
                deselect selected
            }
        }
    }
}
   
#------------------------------------------------------------
# Line drawing on the symbol
#------------------------------------------------------------

proc icon_line {args} {
    puts stdout "icon_line $args"
    set coords {}
    set i 0
    foreach {x y} $args {
        set s [scale_coord [list $x $y]]
        lappend coords $s
        incr i
    }
    eval "polygon make $i $coords"
}

#------------------------------------------------------------
# Recast schematic commands in a namespace used for a
# preliminary parsing to discover dependencies
#------------------------------------------------------------

namespace eval parse {
    namespace export make make_wire make_line make_text

    proc make {type args} {
        global deplist

        switch -- $type {
            input -
            output -
            inout -
            name_net -
            name_net_s -
            global -
            text {
            }
            default {
                lappend deplist $type
            }
        }
    }

    proc make_line {args} {
    }

    proc make_wire {x1 y1 x2 y2} {
    }

    proc make_text {args} {
    }
}

#------------------------------------------------------------
# Main routine:  Load the .sue file for the indicated
# gate.  Draw the schematic and the (user library) symbol,
# and associate them.
#------------------------------------------------------------

proc make_sue_gate {filename libname} {
   global deplist

   set name [file tail [file root $filename]]

   # Check if this gate exists and ignore if so (may have been
   # handled already as a dependency to another gate)
   if {![catch {object handle ${name}}]} {return}

   # DIAGNOSTIC
   puts stdout "Sourcing ${filename}"
   source ${filename}

   set deplist {}

   # DIAGNOSTIC
   puts stdout "Evaluating SCHEMATIC_${name} in namespace parse"
   namespace import parse::*
   eval "SCHEMATIC_${name}"

   if {[llength $deplist] > 0} {
       # DIAGNOSTIC
       puts stdout "Handling dependency list."
       foreach dep $deplist {
           make_sue_gate ${dep}.sue $libname
       }
   }

   # DIAGNOSTIC
   puts stdout "Generating new page"

   # Go to a new page unless the current one is empty
   while {[llength [object parts]] > 0} {
      set p [page]
      incr p
      while {[catch {page $p}]} {
         page make
      }
   }

   puts stdout "Evaluating ICON_${name}"
   namespace forget parse::*
   namespace import sue::*

   # Evaluate the symbol.  Generate the symbol in xcircuit.
   # Then clear the page to make the schematic
   eval "ICON_${name}"
   set hlist [object parts]
   object make $name $hlist
   set hlist [object parts]
   push $hlist
   pop
   delete $hlist

   # DIAGNOSTIC
   puts stdout "Evaluating SCHEMATIC_${name} in namespace sue"

   eval "SCHEMATIC_${name}"
   catch {wm withdraw .select}
   schematic associate $name
   zoom view

   # DIAGNOSTIC
   puts stdout "Done."
   namespace forget sue::*
}
 
#------------------------------------------------------------
# Read a .sue file and source it, then format a page around
# the schematic contents.
#------------------------------------------------------------

proc read_sue_file {filename name} {
    config suspend true
    make_sue_gate $filename $name
    page filename $name
    page orientation 90
    page encapsulation full
    page fit true
    if {[page scale] > 1.0} {
        page fit false
        page scale 1.0
    }
    config suspend false
}

#------------------------------------------------------------
# Top-level routine:  Find all the .sue files in the
# current directory and generate a library from them
#------------------------------------------------------------

proc make_all_sue {{name sue_gates}} {
   set files [glob \*.sue]

   foreach filename $files {
      read_sue_file $filename $name
   }
}

#------------------------------------------------------------
# Make sure that the sue technology (.lps file) has been read
# 
#------------------------------------------------------------

if {[lsearch [technology list] sue] < 0} {
   library load sue
   technology prefer sue
}