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.
The variable "runfrom" can be set to "." or to "p101.exe" according to whether it is run as a script or as a tclkit. In either case, it needs a companion "images" directory with the following contents:
The program is below, but it needs a variety of images and so forth. I tried to upload those and got complaints about an image format not being text/wikit format. It would be easiest to just upload the p101.vfs as a zip file. If someone can help me circumvent these issues?
CMcC Could you please elaborate on "No .exe, no .zip, and no .gif either since I somehow changed the type of the file, whatever THAT means" ?
The wiki refuses to upload .exe and .zip files. Likely this is not a bug but a security feature, either one may host malware. Okay, re-reading the image upload and doing it the correct way seems to work - although I find the method counter-intuitive in the extreme - but when I uploaded a .ico file it was still assigned a page number and the .htm extension, and when I did "save Link" and renamed it back to .ico, it didn't work. Likely not 8-bit clean somewhere in the loop.
Now, after some thought, I expect this is because it is assuming that the upload file replaces the original wiki page, and it won't do that. Again, probably a a feature rather than a bug. It leaves me not knowing how to upload an image as such under its own name and type.
Secondly, consider using the Half Bakery for uploading your code. I think the basic problem here is that you're uploading a package which could be modelled as a collection containing several components, and wiki generally doesn't really lend itself to a hierarchy by inclusion.
I hadn't thought of the Half Bakery as a release mechanism. I'll look into that. <sigh>I don't see how to upload here, either. Uploading a .zip or a .tgz add the archive name preceded by an 'x' link, but it doesn't seem to have actually added it to the repository and pressing the x just seems to delete it.</sigh> I really agree with uniquename, a simply upload button would require far less explanation or documentation. It reminds me of the whole "how come Tcl barfs when it sees 09?" controversy.
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