PC speaker, timer reprogramming / ISR, fix IN and OUT instructions

asm.jrt

@@ -334,14 +334,14 @@ var ignoreimm
 : AX? oparg-reg? oparg-val @ 0x00 = and ;
 
 : >inout* ( base )
-  arg2 oparg-reg? oparg-val @ 0x03 ( DX ) = and arg1 if 
+  oparg-reg? oparg-val @ 0x03 ( DX ) = and swap-args if 
     AL? if 8 + >t 2ret then
     AX? if 9 + >t 2ret then
   then 
-  arg2 oparg-imm? arg1 if 
+  swap-args oparg-imm? swap-args if 
-    AL? if >t oparg-val @ >t 2ret then 
+    AL? if swap-args >t oparg-val @ >t 2ret then 
-    AX? if 1+ >t oparg-val @ >t 2ret then
+    AX? if swap-args 1+ >t oparg-val @ >t 2ret then
   then ;
 
-2 :op IN  0xe4 >inout* ;
+2 :op IN  arg2 0xe4 >inout* ;
 2 :op OUT      0xe6 >inout* ;

beep.jrt

@@ -0,0 +1,27 @@
+import timer.jrt
+
+:asm >spk ( div -- )
+  MOV AL 0xb6 #
+  OUT 0x43 # AL
+  POP AX
+  OUT 0x42 # AL
+  MOV AL AH
+  OUT 0x42 # AL
+  IN AL 0x61 #
+  OR AL 0x03 #
+  OUT 0x61 # AL
+  NEXT
+
+:asm silence ( -- )
+  IN AL 0x61 #
+  AND AL 0xfc #
+  OUT 0x61 # AL
+  NEXT
+
+: slide ( div count + -- )
+  >r begin over >spk 1 sleep-csec swap r@ + swap 1- dup not until
+  rdrop drop drop silence ;
+: boop ( div count -- ) swap >spk sleep-csec silence ;
+: noise ( count -- ) 
+  begin rand >spk 1 sleep-csec 1- dup not until drop silence ;
+

common.jrt

@@ -0,0 +1,9 @@
+import text.jrt
+import keys.jrt
+import random.jrt
+
+: !+ ( v p -- ) dup @ <rot + swap ! ;
+: b!+ ( v p -- ) dup b@ <rot + swap b! ;
+: b!| ( f p -- ) dup b@ <rot | swap b! ;
+: b!^ ( f p -- ) dup b@ <rot ^ swap b! ;
+: ~ 0xffff ^ ;

readme.txt

@@ -16,8 +16,8 @@ We start with MINIJORT.EXE, compiled with Borland Turbo C++ from MINIJORT.C
 and MAIN.C. This is a stripped-down version of the Jorth engine that Neut
 Tower[1] was built with, and the only part of this project that existed in
 any form before August 14, 2023. (I started early on the jam because I 
-basically knew what I wanted to implement, and I knew that getting _anything_
+basically knew what I wanted to implement, and with the absurd plan I had in 
-playable by the end of September with the absurd plan I had in mind was
+mind, I knew that getting _anything_ playable by the end of September was
 going to be a long shot.) MINIJORT.EXE is a simple Forth interpreter that
 loads BOOT.JOR and then reads the rest of its input from stdin.
 

swine.jrt

@@ -1,12 +1,10 @@
-import text.jrt
+import timer.jrt
-import keys.jrt
+import beep.jrt
-import random.jrt
 
-: !+ ( v p -- ) dup @ <rot + swap ! ;
+: meep 2000 5 -80 slide ;
-: b!+ ( v p -- ) dup b@ <rot + swap b! ;
+: moop 1600 5 80 slide ;
-: b!| ( f p -- ) dup b@ <rot | swap b! ;
+: boom 40 noise ;
-: b!^ ( f p -- ) dup b@ <rot ^ swap b! ;
+: click 2000 3 boop 4000 3 boop ;
-: ~ 0xffff ^ ;
 
 0 const IN-PROGRESS
 1 const CANCEL
@@ -114,10 +112,13 @@ var neighbour-check
 
 : reveal-unflagged-neighbours? ( p -- )
   dup square-pos count-surrounding-flags over squarecount =
-  if square-pos ' reveal do-neighbour-squares else drop then ;
+  if click square-pos ' reveal do-neighbour-squares else drop then ;
 : reveal-at square-at dup revealed? 
-  if reveal-unflagged-neighbours? else reveal then autoreveal check-win ;
+  if reveal-unflagged-neighbours? else reveal click then 
-: flag-at square-at dup revealed? not if FFLAG swap b!^ else drop then ;
+  autoreveal check-win ;
+: flag-noise ( p -- ) b@ FFLAG & if moop else meep then ;
+: flag-at square-at dup revealed? not 
+  if FFLAG swap dup flag-noise b!^ else drop then ;
 
 ( theming )
 array countcolors white b, lblue b, lgreen b, red b, blue b, 
@@ -269,10 +270,11 @@ var current-menu
   5 popupbox ( x ) 10 textxy! draw-spaced-text 
   wait-key drop ;
 
+: fanfare meep moop meep moop meep moop meep ;
 : display-result
   game-state b@
-  dup WON = if green bg! lcyan fg! s" YOU WON" 26 result-message then
+  dup WON = if fanfare green bg! lcyan fg! s" YOU WON" 26 result-message then
-     LOST = if red bg! yellow fg! s" YOU LOST" 25 result-message then ;
+     LOST = if boom red bg! yellow fg! s" YOU LOST" 25 result-message then ;
 
 2 :noname blue bg! lgray fg! 4 popupbox ; defmenu quitmenu
 ' leave                      s" Return to game" 0 defitem
@@ -285,7 +287,7 @@ var current-menu
   begin draw-game await-command confirm-quit in-progress? not until 
   draw-board display-result enter ;
 
-: start init-board play ;
+: start init-board boardw @ 2/ cursx b! boardh @ 2/ cursy b! play ;
 
 ( title menu )
 array title-text t", SWINE MEEPER"
@@ -316,7 +318,9 @@ array title-text t", SWINE MEEPER"
 ' theme-menu      s" Themes"     2 defitem
 ' leave           s" Quit"       3 defitem
 
-: title textmode reseed! hidecursor title-menu textmode ;
+: title install-timer textmode reseed! hidecursor 
+  title-menu 
+  textmode uninstall-timer ;
 
 ' title ' main redefine
 

timer.jrt

@@ -0,0 +1,68 @@
+:asm intvect@ ( int -- seg off )
+  XOR BX BX
+  MOV ES BX
+  POP BX
+  SHL BX 1 #
+  SHL BX 1 #
+  PUSH @[ 2 @+ ES: BX]
+  PUSH @[ ES: BX]
+  NEXT
+
+:asm intvect! ( seg off int -- )
+  XOR BX BX
+  MOV ES BX
+  POP BX
+  SHL BX 1 #
+  SHL BX 1 #
+  CLI
+  POP @[ ES: BX]
+  POP @[ 2 @+ ES: BX]
+  STI
+  NEXT
+
+: irq 8 + ;
+
+{ :timm :asmisr ( int -- ) ARRAY 4 ALLOT w>t CLI PUSH AX ;
+  :timm ISR-DONE MOV AL 0x20 # OUT 0x20 # AL POP AX STI IRET ;
+  :timm CHAIN-ISR ( isr -- )
+    POP AX
+    STI
+    JMP FAR CS: @+ ; }
+
+:asm get-cseg
+  PUSH CS
+  NEXT
+
+: isr>int ( isr -- int ) 2 cells + @ ;
+: isr>code ( isr -- p ) 3 cells + ;
+: uninstall-isr ( isr -- )
+  >r r@ cell + @ r@ @ <r isr>int intvect! ;
+: install-isr ( isr -- ) 
+  >r r@ isr>int intvect@ r@ ! r@ cell + ! 
+  get-cseg r@ isr>code <r isr>int intvect! ;
+
+var timer
+0 irq :asmisr timer-isr
+  MOV AX CS: timer @+
+  INC AX
+  MOV CS: timer @+ AX
+  AND AX 0x03 #
+  JZ 0 @>
+  ISR-DONE
+0 <:
+  timer-isr CHAIN-ISR
+
+:asm set-timer-div ( div -- )
+  MOV AL 0x36 #
+  OUT 0x43 # AL
+  POP AX
+  OUT 0x40 # AL
+  MOV AL AH
+  OUT 0x40 # AL
+  NEXT
+
+: sleep-csec ( cs -- )
+  timer @ + begin dup timer @ <= until drop ;
+: install-timer 0xffff 2 >> set-timer-div timer-isr install-isr ;
+: uninstall-timer 0xffff set-timer-div timer-isr uninstall-isr ;
+

zipoff.jrt

@@ -162,5 +162,7 @@ dbg" boot"
   MOV BP 0x00 #
   NEXT
 
+} import common.jrt {
+
 here s", zipstub.seg" s" zipoff.com" writeenv