My first computer was an Olivetti Programma 101 owned by my high school, and I spent many hours learning how to program using it. As chance would have it, it was also the first computer my wife worked with as well - though she only got a few hours. At any rate, I wrote this for my wife's birthday. Those of you who have also used this machine will recognize it immediately.

This program is not typical Tcl. Because our current computers have quite different screen resolutions, I needed to make it resizable, at least to ''some'' extent. So I came up with a system to generate a display from a bitmap, and widgets are located by decimal places - .5 would be 50% of the way from the left side, and so on. It also extracts the actual button label from that portion of the image, so I don't need to specify it separately.

This program has been lightly tested, but there are probably still bugs. The worst I've dealt with are actually edit errors that moved widgets to West Succotash, Iowa or someplace because I dinged the table of widget placement data. Hopefully, this version straightens out all of that. It should also be noted there are quite a few new features added to the architecture to make it a little less painful to program, including editing of programs (if you made a mistake in entering the current instruction you could CLEAR and re-enter it, but if you don't notice the error right away and spot it scrolling up while you are entering a different command, well, you ''lose'' and you have to re-enter the whole program all over again). Also, the blue buttons represent various extended functions allowing you to display the registers, edit the labels, and so on, and I also added the "rub out" button and the keyboard buffer display. You just had to remember what digits you keyed in with the actual hardware.

Aside from these additions the layout exactly follows the original except for moving the decimal wheel from the right to the left.
Oh, well, I guess I'm not allowed to upload that, either. No .exe, no .zip, and no .gif either since I somehow changed the type of the file, whatever THAT means. If someone can help me circumvent these issues?

======
package provide app-p101 1.0
# set runfrom p101.exe
set runfrom .

proc setfonts { brw brh bufw dispch spfnsz brfnsz \
                txtfnsz HLfnsz abtfnsz regfnsz lblfnsz \
} {
  set ::brheight $brh
  set ::brwidth $brw
  set ::bufwidth $bufw
  set ::dispch $dispch
  set ::spfn [ font create -family courier -weight bold -size $spfnsz ]
  set ::brfn [ font create -family courier -weight bold -size $brfnsz ]
  set ::txtfn [ font create -family courier -weight bold -size $txtfnsz ]
  set ::HLfn [ font create -family tahoma -weight bold -size $HLfnsz ]
  set ::abtfn [ font create -family tahoma -weight normal -size $abtfnsz ]
  set ::regfn [ font create -family tahoma -size $regfnsz ]
  set ::lblfn [ font create -family tahoma -weight normal -size $lblfnsz ]
}

proc log { msg } {
  if !$::uselog return
  if !$::logopen {
    if { [ catch {
      set ::logfile [ open ./logfile.txt w ]
      set ::logopen 1
    } error ] != 0 } {
      set ::uselog 0
    }
  }
  puts $::logfile $msg
  flush $::logfile
}

proc announce { msg } {
  tk_messageBox -parent .top -title "Info" \
    -icon info -type ok -message $msg
}

proc reset { { override 0 } } {
  if !$override {
    if {[tk_messageBox -parent . -title "Are you sure?" \
           -icon question -type yesno -default no \
           -message "Reset P101 Simulator?"] ne "yes"
    } {
      return
    }
  }
  .top.printarea.text delete 0.0 end
  .prog.list.list delete 0 end
  .prog.list.list insert end "end" ; renum .prog.list
  set ::pc 0
  set ::reg ""
  set ::confirm 0
  set ::entering 0
  set ::recording 0
  set ::interactive 1
  set ::register(A) 0.0
  set ::register(B) 0.0
  set ::register(b) 0.0
  set ::register(C) 0.0
  set ::register(c) 0.0
  set ::register(D) 0.0
  set ::register(d) 0.0
  set ::register(E) 0.0
  set ::register(e) 0.0
  set ::register(F) 0.0
  set ::register(f) 0.0
  set ::register(R) 0.0
  set ::register(M) 0.0
  set stack {}
  set regstack {}
  .top.red configure -bg $::dkred
  foreach w $::btnlist { $w configure -state normal }
  .top.face delete vwyzlbl
  updlbls
}

proc down { reg } {
  set ::register(A) $::register($reg)
  interactive $::register($reg) $reg \u2193
}

proc up { reg } {
  set ::register($reg) $::register(M)
  interactive $::register($reg) $reg \u2191
}

proc swap { reg } {
  if { $reg eq "/" } {
      set A $::register(A)
      set ::register(M) [= {$A-entier($A)} ]
      interactive $::register(M) / \u2195
    return
  }
  if { $reg eq "A" } { 
    set ::register(A) [= {abs($::register(A))}]
  } else {
    set temp $::register(A)
    set ::register(A) $::register($reg)
    set ::register($reg) $temp
  }
  interactive $::register($reg) $reg \u2195
}

proc sqrt { reg } {
  set ::register(A) [= {sqrt($::register($reg))}]
  set ::register(M) $::register($reg)
  interactive $::register(A) $reg \u221a
}

proc minus { reg } {
  set ::register(A) [= {$::register(A) - $::register($reg)}]
  set ::register(M) $::register($reg)
  interactive $::register(A) $reg -
}

proc times { reg } {
  set ::register(A) [= {$::register(A) * $::register($reg)}]
  set ::register(M) $::register($reg)
  interactive $::register(A) $reg \u00d7
}

proc plus { reg } {
  set ::register(A) [= {$::register(A) + $::register($reg)}]
  set ::register(M) $::register($reg)
  interactive $::register(A) $reg +
}

proc divide { reg } {
  set A [= {entier($::register(A))}]
  if {[ string first "." $::register(A) ] == -1 } {
    set ::register(A) $::register(A).0
  }
  if { 0 != [ catch {
    set ::register(A) [= {$::register(A) / $::register($reg)}]
    set ::register(R) 0
    set R [= {entier($::register($reg))}]
    set ::register(R) [= {$A % $R}]
    set ::register(M) $::register($reg)
    interactive $::register(A) $reg \u00f7
  } ] } { redlight -1.0 }
}

proc zero { reg } {
  set ::register($reg) 0
  interactive $::register($reg) ${reg} *
}

proc prreg { reg } {
  type $::register($reg) ${reg}\u25c7
}

proc renum { w } {
  $w.linecount delete 0 end
  set maxj [ $w.list index end ]
  for { set j 0 } { $j < $maxj } { incr j } {
    $w.linecount insert end $j
  }
}

proc insins { instr } {
  .prog.list.list insert $::pc "$instr"
  type "$::pc: $instr"
  renum .prog.list
}

proc delins { } {
  if { [ .prog.list.list get $::pc ] eq "end" } return
  .prog.list.list delete $::pc $::pc
  renum .prog.list
}

proc clear { } {
  if $::recording {
    delins
    return
  }
  .top.red configure -bg $::dkred
  .top.buffer.entry delete 0 end
  foreach w $::btnlist { $w configure -state normal }
}

proc recprog { } {
  if $::recording {
    set ::recording 0
    .top.recprog configure -relief raised
    type "...end"
    return
  }
  type "Begin..."
  set ::recording 1
  .top.recprog configure -relief sunken
  .top.buffer.entry delete 0 end
}

proc prprog { } {
  type "Listing..."
  set maxj [ .prog.list.list index end ]
  for { set j 0 } { $j < $maxj } { incr j } {
    set ins [ .prog.list.list get $j ]
    type "$j: $ins"
  }
  type "...end"
}

proc paperadv { } { type "" }
proc paperclr { } {
  .top.printarea.text delete 1.0 end
  set ::value ""
}
proc papersav { } {
  set tapename [ tk_getSaveFile -defaultextension .txt \
    -initialdir . -parent .top -title "Save Paper Tape..." ]
  if { $tapename ne "" } {
    set f [ open $tapename w ]
    fconfigure $f -encoding utf-8
    set tape [ .top.printarea.text get 1.0 end ]
    puts $f $tape
    close $f
  }
}

proc page { number } {
  if { $::curpage != 0 } {
    grid forget .top.about.pg${::curpage}txt
    .top.about.pg${::curpage} configure -relief groove
  }
  set ::curpage $number
  grid .top.about.pg${number}txt -row 3 -column 0 -columnspan 6 -rowspan 20 -sticky news
  .top.about.pg${::curpage} configure -relief solid
}

proc manual { } {
  set savename [ tk_getSaveFile -defaultextension pdf \
    -initialfile olpro101.pdf \
    -parent .top -title "Save Manual To..." ]
  if { $savename ne "" } {
    file copy -force $::manpdf $savename
  }
}

proc prefs { } {
  destroy .top.options
  toplevel .top.options
  label .top.options.title -text "PROGRAMMA-101\nSIMULATOR OPTIONS"
  grid .top.options.title -row 0 -column 0 -columnspan 2
  checkbutton .top.options.animation \
    -variable ::animation -text "Card Animation"
  grid .top.options.animation -row 1 -column 0
  button .top.options.close -text "Close Options" -command {
    destroy .top.options 
  }
  button .top.options.manual -text "Save Manual" -command manual
  grid .top.options.manual -row 2 -column 0
  grid .top.options.close -row 3 -column 0 -columnspan 2
}

proc about { } {
  set tabs \t
  if { $::size == 100 } { set tabs \t\t }
  destroy .top.about
  toplevel .top.about
  label .top.about.title -text "OLIVETTI-UNDERWOOD\nPROGRAMMA 101" \
    -font $::HLfn
  grid .top.about.title -row 0 -column 0 -columnspan 5
  label .top.about.blurb -text "by Larry Smith" -font $::HLfn
  grid .top.about.blurb -row 1 -column 0 -columnspan 5
  button .top.about.pg1 -command { page 1 } -text "Credits" \
    -font $::HLfn -relief groove
  grid .top.about.pg1 -row 2 -column 0
  button .top.about.pg2 -command { page 2 } -text "Machine" \
    -font $::HLfn -relief groove
  grid .top.about.pg2 -row 2 -column 1
  button .top.about.pg3 -command { page 3 } -text "Simulator" \
    -font $::HLfn -relief groove
  grid .top.about.pg3 -row 2 -column 2
  button .top.about.pg4 -command { page 4 } -text "Basic Ops" \
    -font $::HLfn -relief groove
  grid .top.about.pg4 -row 2 -column 3
  button .top.about.pg5 -command { page 5 } -text "Extensions" \
    -font $::HLfn -relief groove
  grid .top.about.pg5 -row 2 -column 4
  label .top.about.pg1txt -width 66 -bd 5 -relief solid -justify left -font $::abtfn -text "© 2009 by Larry Smith\n\nWritten for Marjie Smith, my wife, for her birthday.  The Olivetti\nProgramma 101 was the first real computer I ever used and it was\nthe first Marjie ever used, too.  It has great nostalgic value for us.\n\n\n\n\n\n\n"
  label .top.about.pg2txt -width 66 -bd 5 -relief solid -justify left -font $::abtfn -text "The Programma 101 was the first machine to be marketed as\n\"microcomputer\".  It was built with many transistors worth of\ndiscrete logic, and used a delay line to implement the memory\nregisters.  By modern standards it was limited - five registers\n(B, C, D, E and F) which could each be split in two if you could\nlive with half the accuracy).  It stored just 48 instructions in\nits program, and began eating up registers F, E, and D if you\nexceeded that number, to a maximum of 120 instructions with\nonly two registers left.\n\n\n"
  label .top.about.pg3txt -width 66 -bd 5 -relief solid -justify left -font $::abtfn -text "The simulator emulates the original machine, but it does not\nenforce its' limits.  That is to say, you can split the F register\ninto F and f (F-split) but they are not reduced in size, each is\nreally a separate register.\n\nThe program is also not limited to 48 or 120 steps, it can be any\nlength, and the F, E and D registers are never used.\n\n\n\n\n"
  label .top.about.pg4txt -width 66 -bd 5 -relief solid -justify left -font $::abtfn -text "\[To A\u2193\]\tdown\tTransfers named register to accumulator.\n\[M\u2191\]\tup\tMoves contents of M (keyboard) register to named reg.\n\[A\u2195\]\tswap\tSwitches contents of named register and accumulator.\n\[\u221a\]\tsqrt\tLoads accumulator with the square root of the reg.\n\[\u2014\]\tminus\tSubtracts named reg from accumulator.\n\[\u00d7\]\ttimes\tMultiplies named reg by accumulator.\n\[+\]\tplus\tAdds named reg to accumulator.\n\[\u00f7\]\tdivide\tDivides accumulator by named reg.\n\[*\]\tzero\tStores 0 in named reg.\n\[\u25c7\]\tprreg\tPrints the named reg.\n\[S\]\tstart\tStarts execution at current program step.\n\[/\]\tsplit\tUsed to address split registers a (A/), b (B/) etc."
  label .top.about.pg5txt -width 66 -bd 5 -relief solid -justify left -font $::abtfn -text "Buttons with a blue background are for extensions to the machine.\n\nSave Tape\tSaves contents of display tape to utf-8 text file.\nClear Tape\tClears display tape.\nPush Regs\tSave all regs but A, R & M to internal stack.\nPull Regs\t\tRestore all regs but A, R & M from internal stack.\nProg Library\tSets directory to search for program cards.\nSave Card${tabs}Saves current program to program card.\nShow Labels\tDisplays window to permit editing VXYZ labels.\nShow Regs\tDisplays window showing current contents of regs.\nShow Prog\tDisplays window showing current program.\n"
  button .top.about.exit -text "Exit Simulator" \
    -command off -border 3 -font $::abtfn
  grid .top.about.exit -row 23 -column 1
  button .top.about.close -text "Close About..." \
    -command { destroy .top.about } -border 3 -font $::abtfn
  grid .top.about.close -row 23 -column 3
  page 1
  center .top.about
}

proc setdec { args } {
  set ::tcl_precision $::numdecs
}

proc type { str { suffix "" } } {
  if { $suffix eq "" } {
    set prstr $str
  } else {
    set prstr "[format "%[= {$::dispch-4}].[set ::numdecs]f" $str] ${suffix}"
  }
  .top.printarea.text insert end \n$prstr
  .top.printarea.text see end
}

proc blink { } {
  if $::greenon return
  set ::greenon 1
  .top.green configure -bg $::brgreen
  set delay 300
  if !$::interactive { set delay 100 }
  after $delay {
    .top.green configure -bg $::dkgreen
  set ::greenon 0
  }
}

proc off { } { exit;
  if {[tk_messageBox -parent . -title "Are you sure?" \
         -icon question -type yesno -default no \
         -message "Exit P101 Simulator?"] eq "yes"
  } {
    exit
  }
}

proc redlight { code } {
  .top.green configure -bg $::dkgreen
  .top.red configure -bg $::brred
  if $::interactive { type $code E! } else { type $code PC }
  set ::interactive 1
  foreach w $::btnlist { $w configure -state disabled }
  set ::register(A) 0.0
}

proc jump { label } {
  set ::interactive 0
  set reg [ string index $label 0 ]
  set cond 0
  if { [ string first $reg "/cdr" ] != -1 } {
    set cond 1
  }
  set pc $::pc
  if { !$cond || ($::register(A) > 0) } {
    set pc [ lsearch -exact $::program $::jumps($label) ]
  }
  if { $pc == -1 } {
    set ::interactive 1
    redlight $::pc
    set ::pc 0
    return 0
  }
  set ::pc $pc
  return 1
}

proc isjump { label } {
  set result 0
  if { ($label ne "") && ($label ne " S") } {
    set reg [ string index $label 0 ]
    set cmd [ string index $label 1 ]
    if { ([ string first $cmd "VWYZ" ] != -1 ) &&
         ([ string first $reg " MCDR/cdr" ] != -1 )
       } {
      set result 1
    }
  }
  return $result
}

proc start { { label "" } } {
  if $::recording { set ::curbtn start ; return }
  if { ![info exists ::pc] || ($::pc eq "") } { set ::pc 0 }
  set ::interactive 0
  set ::program [ .prog.list.list get 0 end ]
  if { $label ne "" } { jump $label }
  while 1 {
    blink
    set ins [ lindex $::program $::pc ]
    set cmd [ string index $ins end ]
    set reg [ string index $ins end-1 ]
    incr ::pc
    if { $ins eq "end" } {
      if [ pullstate ] continue
      set ::pc 0
      return
    } elseif { $ins eq " S" } { return
    } elseif { [string first $cmd "VWYZ" ] !=-1 } {
      # either label or branch.  Labels are ignored
      if [ isjump $ins ] {
        if ![jump $ins] return
      }
    } else {
      set cmd $::op2cmd($cmd)
      set value [ string range $ins 0 end-2 ]
      if { $value ne "" } { set ::register(M) $value }
      $cmd $reg
      if $::interactive return
    }
  }
}

proc interactive { str reg op } {
  if $::interactive { type $str ${reg}$op }
  blink
}

proc nextkey { } {
  while 1 {
    vwait ::curbtn
    if { [lsearch $::immediate $::curbtn] != -1 } {
      $::curbtn
    } else {
      set btntype [ string range $::curbtn 0 2 ]
      if { ($btntype eq "num") || ($btntype eq "reg") } {
        set ::curbtn [ string index $::curbtn end ]
        if { $::curbtn eq "!" } { set ::curbtn . }
      } elseif { [ string first $::curbtn "vwyz" ] != -1 } {
        set ::curbtn [ string toupper $::curbtn ]
      } elseif [ info exists ::cmd2op($::curbtn) ] {
        set ::curbtn $::cmd2op($::curbtn)
      }
      return $::curbtn
    }
  }
}

proc backsp { } {
  .top.buffer.entry delete [= {[string length [.top.buffer.entry get]]-1}]
}

proc cmdloop { } {
  set delbuffer 1
  while 1 {
    set reg ""
    set btn [nextkey]
    if {[string first $btn "0123456789.-" ] != -1} {
      if $delbuffer {
        .top.buffer.entry delete 0 end
        set delbuffer 0
        set havedec 0
      }
      if { $btn eq "." } {
        if !$::havedec {
          set ::havedec 1
          .top.buffer.entry insert end .
        }
      } elseif { $btn eq "-" } {
        if {[ string index $::buffer 0 ] eq "-" } {
          .top.buffer.entry delete 0 1
        } else {
          .top.buffer.entry insert 0 -
        }
      } else {
        .top.buffer.entry insert end $btn
      }
      continue
    }
    set value ""
    if { $::buffer ne "" } {
      if { [ string first "." $::buffer ] != -1 } {
        set ::buffer ${::buffer}.0
      }
      set value $::buffer
      if $::interactive { set ::register(M) $value }
    }
    set delbuffer 1
    # value (if any) dealt with.  btn should now be op, split or reg
    if {[string first $btn "ABCDEFMR/"] != -1 } {
      # it's a register name
      set reg [ string index $btn end ]
      set btn [ nextkey ]  ;# look for op or split
      if { $btn eq "/" } {
        set reg [ string tolower $reg ]
        if { $reg eq "m" } { set reg / }
        set btn [nextkey] ;# op MUST follow now
      }
    }
    # we get here we have a reg and op is in btn
    if { $reg eq "" } { set reg M } ;# default register
    if $::recording {
      if { [string first $btn "VWXZ" ] != -1 } {
        if { $reg eq "M" } { set reg " " }
        insins "$value$reg$btn"
      } else {
        if { $btn eq "S" } { set reg " " }
        insins "$value$reg$btn"
      }
      .top.buffer.entry delete 0 end
      incr ::pc
    } else {
      if [ isjump $reg$btn ] {
        start $reg$btn
        set ::interactive 1
        .top.buffer.entry delete 0 end
        .top.buffer.entry insert end $::register(M)
      } else {
            if { [catch { $::op2cmd($btn) $reg } err ] } {
              $btn
        }
          }
    }
  }
}

proc loadlistbox { w values } {
 set j true
 set indx 0
 $w.list delete 0 end
 $w.linecount delete 0 end
 foreach i $values {
   $w.list insert end $i
   $w.linecount insert end $indx
   if {$j} {
     set j false
     $w.list itemconfigure $indx -background #ffffdd
   } else {
     set j true
   }
   incr indx
  }
}

proc scrolledlistbox { w width height values cmd { font "" }} {
log "height is $height"
 if { $font eq "" } { set font $::txtfn } else { set font $::brfn }
 frame $w
 listbox $w.list -width $::brwidth -height $::brheight -font $font
 listbox $w.linecount -width 4 -height $::brheight -font $font
 $w.list configure -yscrollcommand "$w.scrl set"
 #$w.linecount configure -yscrollcommand "$w.scrl set"
 scrollbar $w.scrl -command "$w.list yview; $w.linecount yview"
 pack $w.scrl -side right -fill y
 pack $w.linecount -side left -fill y
 pack $w.list -side left -fill both -expand 1
 loadlistbox $w $values
 # bindings
 #
 # this will obtain the item clicked, and then pass
 # the value onto the proc specified in the variable cmd.
 eval "bind $w.list <ButtonRelease-1> \{$cmd \[\%\W get \@\%x,\%y\]\}"
 # return the widget path
 return $w
}

proc scrolledtextarea {w l t r b } {
  set width [= {round(($r-$l)*$::dispw)}]
  set height [= {round(($b-$t)*$::disph)}]
  set x [= {round($l*$::dispw)}]
  set y [= {round($t*$::disph)}]
  frame $w -width $width -height $height -bd 2 -bg white
  place $w -x $x -y $y
  scrollbar $w.vscroll -orient vertical -command [ list $w.text yview ]
  scrollbar $w.hscroll -orient horizontal -command [ list $w.text xview ]
  text $w.text -yscrollcommand [ list $w.vscroll set ] \
    -xscrollcommand [ list $w.hscroll set ] \
    -font $::txtfn -bg white -width 1 -height 4 -width $::dispch
  pack $w.vscroll -side right -fill y
  pack $w.hscroll -side top -fill x
  pack $w.text -side left
}

proc uptodate {filename {time 0}} {
  set filename [file join [pwd] $filename]
  set mtime [file mtime $filename]
  if {$mtime > $time} {source $filename}
  after 1000 [list uptodate $filename $mtime]
} ;#RS

proc reloadlib {} {
  set proglist ""
  catch { set proglist [glob -directory $::library *.p101] }
  .top.cardlist.list delete 0 end
  foreach file $proglist {
    .top.cardlist.list insert end $file
  }
  renum .top.cardlist
}

proc proglib {} {
  set newlib [ tk_chooseDirectory  -initialdir $::library \
    -mustexist 1 -parent .top -title "Library Directory" ]
  if { $newlib ne "" } { set ::library $newlib }
}

proc savecard {} {
  set progname [ tk_getSaveFile -defaultextension p101 \
    -initialdir $::library -parent .top -title "Save Program To..." ]
  if { $progname ne "" } {
    set f [ open $progname w ]
    fconfigure $f -encoding utf-8
    puts $f "[ .prog.list.list get 0 end ]"
    foreach reg { A B b C c D d E e F f R } {
      puts $f $::register($reg)
    }
    foreach lbl { v w y z } {
      set text [.vwyz.${lbl}txt get 1.0 end ]
      set text [ split $text \n ]
      set text [ join $text "\\n" ]
      puts $f $text
    }
    puts $f $::pc
    puts $f $::numdecs
    close $f
  }
  animatecard 1
  reloadlib
}

proc runcard { args } { 
  set cardname $::register(M)
  set ::register(M) 0.0
  pushstate $cardname
}

set ::animating 0
proc animatecard { { reverse 0 } } {
  if $::animating return
  set ::animating 1
  destroy .card
  if !$::animation return
  set cardw [ image width card ]
  set cardh [ image height card ]
  toplevel .card
  wm overrideredirect .card 1
  canvas .card.c -width $cardw -height $cardh
  pack .card.c
  .card.c create image 0 0 -image card -anchor nw
  update
  set leftsh [= {round($::dispw*0.6955)}]
  set bottomsh [= {round($::disph*0.031 )}]
  set left [= {[ winfo rootx .top ] + $leftsh}]
  set showlabels 0
  if $reverse {
    set bottom [= {[winfo rooty .top.cdrdr] + $bottomsh}]
    set curh 1
    while { $curh < $cardh } {
      wm geometry .card ${cardw}x$curh+$left+$bottom
      update
      incr curh
      incr bottom -1
    }
  } else {
    set rooty [winfo rooty .top.cdrdr]
    set cardh [winfo height .card]
    set bottom [= {$rooty-$cardh+$bottomsh}]
    set curh $cardh
    while { $curh > 0 } {
      wm geometry .card ${cardw}x$curh+$left+$bottom
      update
      incr curh -1
      incr bottom
    }
  }
  set ::animating 0
  destroy .card
  update
}

proc loadprog { } {
  foreach ins $::program {
    .prog.list.list insert end $ins
  }
}

proc loadcard { cardname } {
  set h [winfo height .top]
  set w [winfo width .top]
  if $::recording {
    insins "$cardname @"
    return
  }
  if { $cardname eq "" } return
  set f [ open $cardname r ]
  fconfigure $f -encoding utf-8
  set ::program [ gets $f ]  
  foreach reg { A B b C c D d E e F f R} {
    set ::register($reg) [ gets $f ]
  }
  foreach lbl { v w y z } {
    .vwyz.${lbl}txt delete 1.0 end
    eval set lbltxt [ gets $f ]
    set lbltxt [ string trim $lbltxt ]
    .vwyz.${lbl}txt insert end $lbltxt
  }
  updlbls
  set ::pc [ gets $f ]
  set ::numdecs [ gets $f ]
  close $f
  .prog.list.list delete 0 end
  loadprog
  renum .prog.list
  wm geometry .top ${w}x$h
  animatecard
}

proc updlbls { } {
  .top.face delete vwxylbls
  set y [= {round($::dispw*.72)}]
  foreach { lbl offset } { v .720 w .800 y .880 z .960 } {
    set x [= {round($offset*$::dispw)}]
    set lbltxt [ .vwyz.${lbl}txt get 1.0 end ]
    if { $lbltxt ne "" } {
      .top.face create text $x $y -fill black -font $::lblfn \
        -tags vwxylbls -anchor s -justify center -text $lbltxt
    }
  }
  .top.face raise vwxylbls
}

proc setpc { instr } {
  set ::pc [ .prog.list.list curselection ]
}

proc showprog { args } {
  if $::progshowing {
    wm withdraw .prog
    set ::progshowing 0
    .top.showprog configure -text "Show\nProg"
  } else {
    wm deiconify .prog
    set ::progshowing 1
    .top.showprog configure -text "Hide\nProg"
  }
}

proc showlabels { args } {
  if $::labelshowing {
    set ::labelshowing 0
    wm withdraw .vwyz
  } else {
    set ::labelshowing 1
    wm deiconify .vwyz
  }
}

proc pushregs { } {
  if $::recording { set ::curbtn pushregs ; return }
  set state [ list \
    $::register(B) $::register(b) $::register(C) $::register(c) \
    $::register(D) $::register(d) $::register(E) $::register(e) \
    $::register(F) $::register(f) ]
  lappend ::regstack $state
}

proc pullregs { } {
  if $::recording { set ::curbtn pullregs ; return }
  if { $::regstack eq {} } { return 0 }
  set state [lindex end $::regstack]
  set ::stack [lrange $::regstack 0 end-1]
  foreach [list \
    ::register(B) ::register(b) ::register(C) ::register(c) \
    ::register(D) ::register(d) ::register(E) ::register(e) \
    ::register(F) ::register(f) ] \
  $state break
  return 1
}

# push and pull save everything but registers AM&R, which can
# be used to pass results back to a previous program
proc pushstate { newcard } {
  lappend ::stack $::program
  lappend ::stack $::pc
  pushregs
  loadcard $newcard
}

proc pullstate { } {
  if { $::stack eq {} } { return 0 }
  set ::pc [lindex end $::stack]
  set ::stack [lrange $::regstack 0 end-1]
  set ::program [lindex end-1 $::stack]
  set ::stack [lrange $::regstack 0 end-1]
  pullregs
  return 1
}

proc showregs { args } {
  if !$::regssetup {
    foreach reg { A B b C c D d E e F f M R } {
      .regs.reglist.linecount insert end $reg
      .regs.reglist.list insert end $::register($reg)
      trace add variable ::register($reg) write updregs
    }
    set ::regssetup 1
  }
  if $::regsshowing {
    wm withdraw .regs
    set ::regsshowing 0
    .top.showregs configure -text "Show\nRegs"
  } else {
    wm deiconify .regs
    set ::regsshowing 1
    .top.showregs configure -text "Hide\nRegs"
  }
}

proc updregs { args } {
  .regs.reglist.list delete 0 end
  foreach reg { A B b C c D d E e F f M R } {
    .regs.reglist.list insert end $::register($reg)
  }
}

proc center { w { width 0 } { height 0 } } {
  update
  if { $width == 0 } { set width [winfo width $w] }
  if { $height == 0 } { set height [winfo height $w] }
  set x [= {([winfo vrootwidth  $w] - $width  ) / 2 }]
  set y [= {([winfo vrootheight $w] - $height ) / 2 }]
  wm geometry $w ${width}x${height}+${x}+${y}
}

proc showsplash { } {
  destroy .splash
  toplevel .splash
  wm overrideredirect .splash 1
  canvas .splash.c
  pack .splash.c -side top -fill both -expand 1
  image create photo splash -file $::runfrom/images/splash.gif
  .splash.c create image 0 0 -image splash -anchor nw
  center .splash 600 655
  update
  after 3000 {
    destroy .splash
  }
}

proc buildvwyz { } {
  destroy .vwyz
  toplevel .vwyz
  wm protocol .vwyz WM_DELETE_WINDOW showlabels
  wm withdraw .vwyz
  label .vwyz.title -text "Labels:" -font regfn
  grid .vwyz.title -row 0 -column 0 -columnspan 2

  label .vwyz.v -text "V:" -font regfn
  grid .vwyz.v -row 1 -column 0 -sticky news
  label .vwyz.w -text "W:" -font regfn
  grid .vwyz.w -row 2 -column 0 -sticky news
  label .vwyz.y -text "Y:" -font regfn
  grid .vwyz.y -row 3 -column 0 -sticky news
  label .vwyz.z -text "Z:" -font regfn
  grid .vwyz.z -row 4  -column 0 -sticky news

  text .vwyz.vtxt -width 10 -font regfn -height 5
  grid .vwyz.vtxt -row 1 -column 1 -sticky news
  text .vwyz.wtxt -width 10 -font regfn -height 5
  grid .vwyz.wtxt -row 2 -column 1 -sticky news
  text .vwyz.ytxt -width 10 -font regfn -height 5
  grid .vwyz.ytxt -row 3 -column 1 -sticky news
  text .vwyz.ztxt -width 10 -font regfn -height 5
  grid .vwyz.ztxt -row 4 -column 1 -sticky news

  button .vwyz.updlbls -font regfn -command updlbls \
    -text "Update Labels"
  grid .vwyz.updlbls -row 5 -column 0 -columnspan 2 -sticky ew
  update
}

proc buildprog { } {
  destroy .prog
  toplevel .prog
  wm protocol .prog WM_DELETE_WINDOW showprog
  wm withdraw .prog
  scrolledlistbox .prog.list 20 10 "" setpc
  .prog.list.list insert end end; renum .prog.list
  label .prog.label -text "Program:" -anchor w
  pack .prog.label .prog.list
  update
}

proc buildregs { } {
  destroy .regs
  toplevel .regs
  wm protocol .regs WM_DELETE_WINDOW showregs
  wm withdraw .regs
  scrolledlistbox .regs.reglist 20 13 "" ""
  label .regs.label -text "Registers:" -anchor w
  pack .regs.label .regs.reglist
  update
}

proc buildgui { args } {
  global size dispw disph
  destroy .top
  toplevel .top
  wm protocol .top WM_DELETE_WINDOW { off }
  image create photo card -file $::runfrom/images/p101card-${size}%.gif
  image create photo p101 -file $::runfrom/images/p101.gif
  image create photo cr -file $::runfrom/images/cardreader-${size}%.gif
  image create photo 1xparentpx -file $::runfrom/images/1xparentpx.gif
  image create photo p101face -file $::runfrom/images/P101-${size}%.gif
  image create photo btnup -file $::runfrom/images/P101-${size}%.gif
  #image create photo btndn \
    -file $::runfrom/images/P101-${size}%-dark.png
  set dispw [ image width p101face ]
  set disph [ image height p101face ]
  switch $size {
    50  { setfonts 18 2 32 33 6 6 8 8 8 8 6 }
    75  { setfonts 22 4 27 29 10 8 14 14 12 12 8 }
    100 { setfonts 20 4 25 28 16 12 20 20 16 16 12 }
  }
  update
  set btns [ list \
    .top.about 0.0852 0.0 0.2335 0.1260 \
    .top.paperadv 0.01052 0.2087 0.0727 0.3930 \
    .top.prefs 0.0096 0.4715 0.0746 0.5556 \
    .top.reset 0.0096 0.5840 0.0746 0.6680 \
    .top.off 0.00956 0.6965 0.0746 0.7805 \
    .top.regF 0.0852 0.4580 0.1703 0.5704 \
    .top.regE 0.0852 0.5705 0.1703 0.6829 \
    .top.regD 0.0852 0.6830 0.1703 0.7953 \
    .top.regC 0.0852 0.7954 0.1703 0.9078 \
    .top.showlabels 0.0852 0.9079 0.1703 0.9986 \
    .top.up 0.1703 0.4580 0.3388 0.5704 \
    .top.regB 0.1703 0.6830 0.3388 0.7953 \
    .top.clear 0.1703 0.5705 0.3388 0.6829 \
    .top.reg/ 0.1703 0.7954 0.3388 0.9078 \
    .top.showregs 0.1703 0.9079 0.2545 0.9986 \
    .top.showprog 0.2555 0.9079 0.3388 0.9986 \
    .top.num7 0.3426 0.4580 0.4230 0.5704 \
    .top.num4 0.3426 0.5705 0.4230 0.6829 \
    .top.num1 0.3426 0.6830 0.4230 0.7953 \
    .top.num0 0.3426 0.7954 0.4230 0.9078 \
    .top.pushregs 0.3426 0.9079 0.4230 0.9986 \
    .top.num8 0.4239 0.4580 0.5091 0.5704 \
    .top.num5 0.4239 0.5705 0.5091 0.6829 \
    .top.num2 0.4239 0.6830 0.5091 0.7953 \
    .top.num! 0.4239 0.7954 0.5091 0.9078 \
    .top.pullregs 0.4239 0.9097 0.5091 0.9986 \
    .top.num9 0.5100 0.4580 0.5943 0.5704 \
    .top.num6 0.5100 0.5705 0.5943 0.6929 \
    .top.num3 0.5100 0.6830 0.5943 0.7953 \
    .top.num- 0.5100 0.7954 0.5943 0.9078 \
    .top.proglib 0.5100 0.9097 0.5942 0.9986 \
    .top.start 0.5962 0.4580 0.6804 0.9078 \
    .top.savecard 0.5962 0.9097 0.6804 0.9986 \
    .top.recprog 0.6813 0.35 0.839 0.41 \
    .top.down 0.6813 0.4580 0.8402 0.5704 \
    .top.minus 0.6813 0.5705 0.7590 0.6929 \
    .top.plus 0.6813 0.6830 0.7590 0.7953 \
    .top.v 0.6813 0.7954 0.7664 0.8550 \
    .top.times 0.7608 0.5705 0.8402 0.6929 \
    .top.divide 0.7608 0.6830 0.8402 0.7953 \
    .top.w 0.7608 0.7954 0.9262 0.8564 \
    .top.prprog 0.8411 0.35 0.999 0.41 \
    .top.swap 0.8411 0.4580 0.9196 0.8550 \
    .top.regA 0.8411 0.5705 0.9196 0.6929 \
    .top.regR 0.8411 0.6830 0.9196 0.7953 \
    .top.y 0.8411 0.7954 0.9196 0.8564 \
    .top.sqrt 0.9206 0.4580 0.9990 0.8550 \
    .top.prreg 0.9206 0.5705 0.9990 0.6929 \
    .top.zero 0.9206 0.6830 0.9990 0.7953 \
    .top.z 0.9206 0.7954 0.9990 .8580 \
    .top.papersav 0.0105 0.1463 0.0727 0.2073 \
    .top.paperclr 0.0105 0.3957 0.0727 0.4566 \
    .top.backsp 0.5962 0.25 0.6804 0.455 \
  ]
  canvas .top.face -width $dispw -height $disph
  .top.face create image 0 0 -image p101face -anchor nw
  place .top.face -x 0 -y 0
  update
  center .top $dispw $disph
  set ::btnlist {}
  foreach { name l t r b } $btns {
    set l [= {round($l*$::dispw)}]
    set t [= {round($t*$::disph)}]
    set r [= {round($r*$::dispw)}]
    set b [= {round($b*$::disph)}]
    image create photo face$name
    face$name copy btnup -from $l $t $r $b
    set cmd [ list set ::curbtn $name ]
    set code [ string range [ file extension $name ] 1 end ]
    button $name -image face$name -command [list set ::curbtn $code] \
      -bd 0 -highlightthickness 0 -activebackground #0000ff
    place $name -x $l -y $t 
        raise $name
    if { ($name ne ".top.clear") && ($name ne ".top.reset") } {
      lappend ::btnlist $name
    }
  }
  # printarea
  foreach { l t r b } { 0.0852 0.127 0.67 0.29 } break
  scrolledtextarea .top.printarea $l $t $r $b
  # buffer
  foreach { x y } { 0.0855 0.390 } break
  frame .top.buffer -bd 2
  place .top.buffer -x [= {round($x*$dispw)}] -y [= {round($y*$disph)}]
  entry .top.buffer.entry -font $::txtfn -textvariable ::buffer -width $::bufwidth
  pack .top.buffer.entry -fill both
  # cardlist
  foreach { x y } { .6813 .125 } break
  scrolledlistbox .top.cardlist $::brwidth $::brheight "" loadcard $::brfn
  place .top.cardlist -x [= {round($x*$dispw)}] -y [= {round($y*$disph)}]
  # card reader
  foreach { w h x y } { 0 0 .681 .2735 } break
  label .top.cdrdr -image cr -anchor nw -bd 0
  place .top.cdrdr -x [= {round($x*$dispw)}] -y [= {round($y*$disph)}]
  # green light
  foreach { w h x y } { .18 .06 .6825 .01 } break
  if { $::size == 50 } { set w .18 }
  label .top.green -bg $::dkgreen -anchor center  -image 1xparentpx \
    -width [= {round($dispw*$w)}] -height [= {round($disph*$h)}] -bd 10 \
    -relief raised
  place .top.green -x [= {round($x*$dispw)}] -y [= {round($y*$disph)}]
  # red light
  foreach { w h x y } { .07 .06 .9 .01 } break
  label .top.red -bg $::dkred -anchor center -image 1xparentpx \
    -width [= {round($dispw*$w)}] -height [= {round($disph*$h)}] -bd 10 \
    -relief raised
  place .top.red -x [= {round($x*$dispw)}] -y [= {round($y*$disph)}]
  # decimal wheel
  foreach { w h x y } { 2 1 .018 .8821 } break
  spinbox .top.decset -from 0 -to 15 -wrap 1 -font $::spfn \
    -width 2 -command setdec -textvariable numdecs
  place .top.decset -x [= {round($x*$dispw)}] -y [= {round($y*$disph)}]

  if $::needreset {
    set ::needreset 0
    buildregs
    buildvwyz
    buildprog
    reset 1
  } else {
    loadprog
  }
  reloadlib
  update
}

proc setsize { {size 0 } } {
  if { $size == 0 } {
    destroy .size
    toplevel .size
    label .size.msg -text "Simulator Display Size?"
    grid .size.msg -row 0 -column 0 -columnspan 4
    button .size.100 -text "100%" -command { setsize 100 }
    grid .size.100 -row 1 -column 0
    button .size.75 -text "75%" -command { setsize 75 }
    grid .size.75 -row 1 -column 1
    button .size.50 -text "50%" -command { setsize 50 }
    grid .size.50 -row 1 -column 2
    button .size.cancel -text "Exit" -command exit
    grid .size.cancel -row 1 -column 3
    center .size
        after 1000 { wm deiconify .size }
  } else {
    destroy .size
    set ::size $size
  }
}

# initialize
package require Tk
wm withdraw .
#set runfrom .
set runfrom p101.exe
set manpdf $::runfrom/olpro101.pdf 
interp alias {} = {} expr
encoding system utf-8
set dkgreen #179fa2
set brgreen #879fa2
set dkred #880000
set brred #ff0000
set btnlist {}
set program {}
set stack {}
set regstack {}
array set op2cmd {
  \u2193 down
  \u2191 up
  \u2195 swap
  \u221a sqrt
  \u2014 minus
  \u00d7 times
  +      plus
  \u00f7 divide
  *      zero
  \u25c7 prreg
  S      start
  /      split
  @      runcard
  (      pushregs
  )      pullregs
}
array set cmd2op {
  down     \u2193
  up       \u2191
  swap     \u2195
  sqrt     \u221a
  minus    \u2014
  times    \u00d7
  plus     +
  divide   \u00f7
  zero     *
  prreg    \u25c7
  start    S
  split    /
  runcard  @
  pushregs (
  pullregs )
}
set uselog 1
set logopen 0
set logfile ""
set recording 0
set curpage 0
set animation 1
set interactive 1
set greenon 0
array set jumps {
  " V" AV
  " W" AW
  " Y" AY
  " Z" AZ
  MV AV
  MW AW
  MY AY
  MZ AZ
  CW BW
  CY BY
  CZ BZ
  DV EV
  DW EW
  DY EY
  DZ EZ
  RV FV
  RW FW
  RY FY
  RZ FZ
  /V aV
  /W aW
  /Y aY
  /Z aZ
  cV bV
  cW bW
  cY bY
  cZ bZ
  dV eV
  dW eW
  dY eY
  dZ eZ
  rV fV
  rW fW
  rY fY
  rZ fZ
}
set immediate [ list recprog prprog prefs reset off clear start \
  papersav paperclr showlabels showregs showprog pushregs pullregs \
  proglib savecard about backsp ]
set havedec 0
set progshowing 0
set progshowing 0
set labelshowing 0
set regsshowing 0
set regssetup 0
set regsshowing 0
uptodate [info script] [file mtime [info script]]
set numdecs 4; setdec
set curbtn ""
trace add variable size write buildgui
set needreset 1
set library .
showsplash
after 2000
setsize
cmdloop
======

<<categories>>Retrocomputing Simulator