From 9e4028e94d27896eecbf61a45f9ce6fb0aaff4bf Mon Sep 17 00:00:00 2001
From: Krispin Schulz <krispin.schulz@dikom-bb.de>
Date: Tue, 7 Nov 2023 22:47:12 +0100
Subject: [PATCH] add basic sprite handling

---
 .gitignore            |   2 +-
 src/emu.tcl           | 250 ++++++++++++++++++++++++++++++++++++------
 src/uxn.tcl           | 197 ++++++++++++++++++++++++---------
 test/hello-pixels.tal |  27 +++++
 4 files changed, 386 insertions(+), 90 deletions(-)
 create mode 100644 test/hello-pixels.tal

diff --git a/.gitignore b/.gitignore
index a511d4e..e5d6f09 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,3 @@
 .DS_Store
 *.rom
-.rom.sym
+*.rom.sym
diff --git a/src/emu.tcl b/src/emu.tcl
index 59d9069..52ea479 100644
--- a/src/emu.tcl
+++ b/src/emu.tcl
@@ -1,31 +1,203 @@
 lappend auto_path [pwd]
 
-package require Tk
+package require Tk 8.6
 package require uxn 1.0
 
-wm title . "tuxn"
-# wm minsize . 512 320
-# wm maxsize . 512 320
-# wm resizable . 0 0
+variable system_colors
+# Set default system colors RGB x 4:
+array set system_colors { 0 {0 0 0} 1 {0 0 0} 2 {0 0 0} 3 {0 0 0} }
 
-grid [tk::canvas .canvas] -sticky nwes -column 0 -row 0
-# grid columnconfigure . 0 -weight 1
-# grid rowconfigure . 0 -weight 1
-
-# bind .canvas <1> "set lastx %x; set lasty %y"
-# bind .canvas <B1-Motion> "addLine %x %y"
+variable blending {
+  {0 0 0 0 1 0 1 1 2 2 0 2 3 3 3 0}
+  {0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3}
+  {1 2 3 1 1 2 3 1 1 2 3 1 1 2 3 1}
+  {2 3 1 2 2 3 1 2 2 3 1 2 2 3 1 2}
+}
 
-# proc addLine {x y} {
-#   .canvas create line $::lastx $::lasty $x $y
-#   set ::lastx $x; set ::lasty $y
-# }
+# grid [tk::canvas .canvas] -sticky nwes -column 1 -row 0
 
 # puts [::tcl::unsupported::representation $ram]
 
 set romfile [lindex $argv 0]
 
 # Scale pixels:
-variable pixel_size 4
+variable pixel_size 1
+
+proc generate_data {width height} {
+  set data [list]
+  for {set x 0} {$x < $width} {incr x} {
+    set row [list]
+    for {set y 0} {$y < $height} {incr y} {
+       lappend row #ff00ff
+       # [format "#%02x%02x%02x" [random_byte] [random_byte] [random_byte]]
+    }
+    lappend data $row
+  }
+  return $data
+}
+ 
+proc random_byte {} {
+   return [expr {int(rand() * 256)}]
+}
+
+variable bg [image create photo]
+variable fg [image create photo]
+
+canvas .canvas
+
+# label .l -image $bg
+
+# label .l -image bg
+# label .l -text "In the\nMiddle!" -bg black -fg white
+# place .canvas -x 0 -y 0
+pack .canvas
+
+proc screen_blank {} {
+  .canvas configure -background [system_color_hex 0]
+}
+
+# index is 0 (R), 1 (G) or 2 (B)
+proc system_set_colors {val index} {
+  variable system_colors
+  set i 0
+  foreach hex [split [format %.4x $val] {}] {
+    set rgb $system_colors($i)
+    scan $hex %x decimal
+    lset rgb $index $decimal
+    set system_colors($i) $rgb
+    incr i
+  }
+  screen_blank
+}
+
+proc system_set_r {val} {
+  system_set_colors $val 0
+}
+
+proc system_set_g {val} {
+  system_set_colors $val 1
+}
+
+proc system_set_b {val} {
+  system_set_colors $val 2
+}
+
+variable screen_width 0
+variable screen_height 0
+
+proc screen_pixel {x y fg color} {
+  variable pixel_size
+  set hex_color [system_color_hex $color]
+  .canvas create rectangle $x $y [expr $x + $pixel_size] [expr $y + $pixel_size] -outline "" -fill $hex_color
+}
+
+proc screen_sprite { auto x y addr val } {
+  variable pixel_size
+  variable system_colors
+  variable blending
+  variable bg
+  variable fg
+
+  set 2bpp [expr !!($val & 0x80)]
+  set length [expr $auto >> 4]
+  set ctx [expr $val & 0x40 ? {$fg} : {$bg}]
+  set color [expr $val & 0xf]
+  set opaque [expr $color % 5]
+  set flipx [expr $val & 0x10]
+  set fx [expr $flipx ? -1 : 1]
+  set flipy [expr $val & 0x20]
+  set fy [expr $flipy ? -1 : 1]
+  set dx [expr ($auto & 0x1) << 3]
+  set dxy [expr $dx * $fy]
+  set dy [expr ($auto & 0x2) << 2]
+  set dyx [expr $dy * $fx]
+  set addr_incr [expr ($auto & 0x4) << (1 + $2bpp)]
+
+  for { set i 0}  {$i <= $length} {incr i} {
+    set x1 [expr $x + $dyx * $i]
+    set y1 [expr $y + $dxy * $i]
+    # Get 8x8 image data from position:
+    set data [$ctx data -from $x1 $y1 [expr $x1 + 8] [expr $y1 + 8]]
+    for { set v 0}  {$v < 8} {incr v} {
+      set c [expr [uxn peek8 [expr ($addr + $v) & 0xffff]] | ($2bpp ? [expr [uxn peek8 [expr ($addr + $v + 8) & 0xffff]] << 8] : 0)]
+      set v1 [expr $flipy ? 7 - $v : $v]
+      for { set h 7}  {$h >= 0} {incr h -1; set c [expr $c >> 1]} {
+        set ch [expr ($c & 1) | (($c >> 7) & 2)]
+        if { $opaque || $ch } {
+          # Pixel index:
+          # set index [expr (($flipx ? 7 - $h : $h) + $v1 * 8) * 4]
+          set b [lindex $blending $ch $color]
+          set rgb $system_colors($b)
+          set r [lindex $rgb 0]
+          set g [lindex $rgb 1]
+          set b [lindex $rgb 2]
+          lset data $v $h [format "#%01x%01x%01x" $r $g $b]
+          # imDat.data[imdati+3] = (!b && (ctrl & 0x40)) ? 0 : 255 // alpha
+        }
+      }
+    }
+    $ctx put $data -to $x1 $y1
+    set addr [expr $addr + $addr_incr]
+  }
+  if { $auto & 0x1 } {
+    set x [expr $x + $dx * $fx]
+    uxn device_poke16 [expr 0x28] $x
+  }
+  if { $auto & 0x2 } {
+    set y [expr $y + $dy * $fy]
+    uxn device_poke16 [expr 0x2a] $y
+  }
+  if { $auto & 0x4 } {
+    uxn device_poke16 [expr 0x2c] $addr
+  }
+}
+
+proc screen_set_width {width} {
+  variable screen_width
+  variable bg
+  variable fg
+  
+  set screen_width $width
+  window_set_size
+  .canvas configure -width $width
+  $bg configure -width $width
+  $fg configure -width $width
+}
+
+proc screen_set_height {height} {
+  variable screen_height
+  variable bg
+  variable fg
+
+  set screen_height $height
+  window_set_size
+  .canvas configure -height $height
+  $bg configure -height $height
+  $fg configure -height $height
+}
+
+# Return hex color of rgb list:
+proc color_hex {rgb} {
+  set r [lindex $rgb 0]
+  set g [lindex $rgb 1]
+  set b [lindex $rgb 2]
+  return [format "#%.1x%.1x%.1x" $r $g $b]
+}
+
+# Pass system color index and get hex color:
+proc system_color_hex {index} {
+  variable system_colors
+
+  set rgb $system_colors($index)
+  return [color_hex $rgb]
+}
+
+proc window_set_size {} {
+  variable screen_width
+  variable screen_height
+  wm minsize . $screen_width $screen_height
+  wm maxsize . $screen_width $screen_height
+}
 
 if { $argc < 1 || $romfile == "--help"} {
   puts "usage: tclkit $argv0 file.rom \[args...\]"
@@ -48,27 +220,33 @@ if { $argc < 1 || $romfile == "--help"} {
   uxn set_debug 1
   uxn init
 
-  # .System/r:
-  uxn watch [expr 0x08] { val { puts "SET R: [format %02x $val]" } }
+  screen_set_width [uxn screen_get_width]
+  screen_set_height [uxn screen_get_height]
 
-  # .Console/write:
-  uxn watch [expr 0x18] { val { puts -nonewline stdout [format %c $val] } }
-  
-  #  .Screen/pixel:
-  uxn watch [expr 0x2e] { {x y} {
-    variable pixel_size
-    puts "x: $x y: $y"
-    .canvas create rectangle $x $y [expr $x + $pixel_size] [expr $y + $pixel_size] -outline "" -fill black
-  }}
+  wm title . "tuxn : $romfile"
+  wm resizable . 0 0
+  window_set_size
+
+  .canvas configure -borderwidth 0 -highlightthickness 0 -width $screen_width -height $screen_height
+
+  .canvas create image 255 160 -image $bg
+  # .canvas create image 0 0 -image $fg
+
+  # Save callback function to handle events of ports:
+  uxn watch .System/red { val { system_set_r $val }}
+  uxn watch .System/green { val { system_set_g $val }}
+  uxn watch .System/blue { val { system_set_b $val }}
+
+  uxn watch .Console/write { val { puts -nonewline stdout [format %c $val] } }
   
+  uxn watch .Screen/width { val { screen_set_width $val } }
+  uxn watch .Screen/height { val { screen_set_height $val } }
+  uxn watch .Screen/pixel { {x y fg color} { screen_pixel $x $y $fg $color } }
+  uxn watch .Screen/sprite { {auto x y addr val} { screen_sprite $auto $x $y $addr $val } }
+  # uxn watch .Screen/vector { val { puts "LOLLLL: $val" } }
+  # uxn watch .Screen/x { val {  } }
+  # uxn watch .Screen/y { val {  } }
+
   uxn load $program
   uxn eval [expr 0x0100]
-}
-
-
-# # ASCII:
-# set byte1 "\uff"
-# set byte2 [string repeat "\uff" 5]
-# puts $byte1
-# puts $byte2
-# [format "%d" 0x$a$b]
\ No newline at end of file
+}
\ No newline at end of file
diff --git a/src/uxn.tcl b/src/uxn.tcl
index 5f45710..16a6c32 100644
--- a/src/uxn.tcl
+++ b/src/uxn.tcl
@@ -24,6 +24,10 @@ namespace eval ::uxn {
   variable rst_offset [expr 0x11000]
   variable device_offset [ expr 0x12000 ]
 
+  # Default screen size:
+  variable screen_width 512
+  variable screen_height 320
+
   # Loaded program:
   variable program
 
@@ -69,6 +73,40 @@ namespace eval ::uxn {
     LIT2r  INC2kr POP2kr NIP2kr SWP2kr ROT2kr DUP2kr OVR2kr EQU2kr NEQ2kr GTH2kr LTH2kr JMP2kr JCN2kr JSR2kr STH2kr
     LDZ2kr STZ2kr LDR2kr STR2kr LDA2kr STA2kr DEI2kr DEO2kr ADD2kr SUB2kr MUL2kr DIV2kr AND2kr ORA2kr EOR2kr SFT2kr
   "
+
+  variable ports "
+    .System/vector .System/vector* .System/expansion .System/expansion* .System/wst .System/rst .System/metadata .System/metadata*
+    .System/red .System/red* .System/green .System/green* .System/blue .System/blue* .System/debug .System/state
+
+    .Console/vector .Console/vector* .Console/read 13 14 15 16 .Console/type 
+    .Console/write .Console/error 1a 1b 1c 1d 1e 1f
+
+    .Screen/vector .Screen/vector* .Screen/width .Screen/width* .Screen/height .Screen/height* .Screen/auto 27
+    .Screen/x .Screen/x* .Screen/y .Screen/y* .Screen/addr .Screen/addr* .Screen/pixel .Screen/sprite
+
+    .Audio/vector .Audio/vector* .Audio/position .Audio/position* .Audio/output 35 36 37
+    .Audio/adsr .Audio/adsr* .Audio/length .Audio/length* .Audio/addr .Audio/addr* .Audio/volume .Audio/pitch
+
+    40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f
+    50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f
+    60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f
+    70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f
+
+    .Controller/vector .Controller/vector* .Controller/button .Controller/key 84 P2 P3 P4
+    88 89 8a 8b 8c 8d 8e 8f
+
+    .Mouse/vector .Mouse/vector* .Mouse/x .Mouse/x* .Mouse/y .Mouse/y* .Mouse/state 97
+    98 99 .Mouse/scrollx .Mouse/scrollx* .Mouse/scrolly .Mouse/scrolly* 9e 9f
+
+    .File/vector .File/vector* .File/success .File/success* .File/stat .File/stat* .File/delete .File/append
+    .File/name .File/name* .File/length .File/length* .File/read .File/read* .File/write .File/write*
+
+    b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf
+
+    .Datetime/year .Datetime/year* .Datetime/month .Datetime/day .Datetime/hour .Datetime/minute .Datetime/second .Datetime/dotw
+    .Datetime/doty .Datetime/doty* .Datetime/isdst cb cc cd ce cf
+  "
+
 }
 
 # handle opcodes:
@@ -205,6 +243,65 @@ proc ::uxn::stack_show {name} {
 # STACK PROCEDURES END
 # 
 
+# 
+# DEVICE PROCEDURES START
+# 
+
+proc ::uxn::device_peek {port} {
+  variable mode_2
+
+  if { $mode_2 } {
+    return [device_peek16 $port]
+  } else {
+    return [device_peek8 $port]
+  }
+}
+
+proc ::uxn::device_peek8 {port} {
+  variable dev
+  return [lindex $dev $port]
+}
+
+proc ::uxn::device_peek16 {port} {
+  return [expr ([device_peek8 $port] << 8) + [device_peek8 [expr $port + 1]]]
+}
+
+# Set value for port and callback device handler:
+proc ::uxn::device_poke {port val} {
+  variable mode_2
+
+  if { $mode_2 } {
+    device_poke16 $port $val
+  } else {
+    device_poke8 $port $val
+  }
+
+  callback $port $val
+}
+
+proc ::uxn::device_poke8 {port val} {
+  variable dev
+  lset dev $port $val
+}
+
+proc ::uxn::device_poke16 {port val} {
+  device_poke8 $port [expr $val >> 8]
+  device_poke8 [expr $port + 1] [expr $val & 0xff]
+}
+
+# 
+# DEVICE PROCEDURE END
+# 
+
+proc ::uxn::screen_get_width {} {
+  variable screen_width
+  return $screen_width
+}
+
+proc ::uxn::screen_get_height {} {
+  variable screen_height
+  return $screen_height
+}
 
 # TODO
 proc ::uxn::halt {err} {
@@ -219,22 +316,19 @@ proc ::uxn::halt {err} {
 # Returns name of opcode:
 proc ::uxn::opcode_name { opcode } {
   variable opcodes
-  # puts "[expr $opcode & 0xff]"
-  # puts [ format %05b [expr $opcode & 0x1f ]]
-  set name [lindex $opcodes $opcode]
-  return $name
+  return [lindex $opcodes $opcode]
 }
 
-# Get wst
-proc ::uxn::wst {} {
-  variable wst
-  return $wst
+# Returns name of port:
+proc ::uxn::port_name { port } {
+  variable ports
+  return [lindex $ports $port]
 }
 
-# Get rst
-proc ::uxn::rst {} {
-  variable rst
-  return $rst
+# Returns number of port by name:
+proc ::uxn::port_number { name } {
+  variable ports
+  return [lsearch $ports $name]
 }
 
 # Get ram
@@ -246,19 +340,28 @@ proc ::uxn::ram {} {
 # Watch port for changes:
 proc ::uxn::watch {port callback} {
   variable device_callbacks
-  set device_callbacks($port) $callback
+  set p $port
+  if { ![string is double -strict $port] } {
+    set p [port_number $port]
+  }
+  set device_callbacks($p) $callback
 }
 
 proc ::uxn::init {} {
   variable wst_offset
   variable rst_offset
   variable ram
+  variable screen_width
+  variable screen_height
   
   # Working stack:
   stack_create wst $wst_offset
   # Return stack:
   stack_create rst $rst_offset
 
+  device_poke16 [expr 0x22] $screen_width
+  device_poke16 [expr 0x24] $screen_height
+
   log "ram size: [llength $ram]"
 }
 
@@ -272,25 +375,6 @@ proc ::uxn::load { rom } {
   }
 }
 
-proc ::uxn::device_poke8 {port val} {
-  variable dev
-  lset dev $port $val
-}
-
-proc ::uxn::device_poke16 {port val} {
-  device_poke8 $port [expr $val >> 8]
-  device_poke8 [expr $port + 1] [expr $val & 0xff]
-}
-
-proc ::uxn::device_peek8 {port} {
-  variable dev
-  return [lindex $dev $port]
-}
-
-proc ::uxn::device_peek16 {port} {
-  return [expr ([device_peek8 $port] << 8) + [device_peek8 [expr $port + 1]]]
-}
-
 proc ::uxn::push { val } {
   variable mode_2
   if { $mode_2 } {
@@ -378,12 +462,13 @@ proc ::uxn::move { distance pc } {
 
 proc ::uxn::callback {port val} {
   variable device_callbacks
-  variable dev
+  variable system_colors
 
   set device "[format %02x [expr $port & 0xf0]]"
   
   log "DEV: $device PORT: [format %02x $port] VAL: [format %02x $val]"
   
+  # variable dev
   # for {set i 0} {$i < 255} {incr i} {
   #   puts "$i : [lindex $dev $i]"
   # }
@@ -391,31 +476,30 @@ proc ::uxn::callback {port val} {
   # Check if callback defined:
   if {[info exists device_callbacks($port)]} {
     set callback $device_callbacks($port)
-    switch [format %02x $port] {
-      # .Screen/pixel
-      2e {
+    set name [port_name $port]
+    switch $name {
+      .Screen/pixel {
+        set x [device_peek16 [expr 0x28]]
+        set y [device_peek16 [expr 0x2a]]
+        # $val is pixel:
+        set fg [expr $val & 0x40]
+        set color [expr $val & 0x3]
+        apply $callback $x $y $fg $color
+      }
+      .Screen/sprite {
+        set auto [device_peek16 [expr 0x26]]
         set x [device_peek16 [expr 0x28]]
         set y [device_peek16 [expr 0x2a]]
-        apply $callback $x $y
+        set addr [device_peek16 [expr 0x2c]]
+        apply $callback $auto $x $y $addr $val
       }
       default { apply $callback $val }
     }
   } else {
-    log "No callback for port [format %02x $port] with val: [format %02x $val]"
+    log "No callback for port [format %.2x $port] with val: [format %.4x $val]"
   } 
 }
 
-proc ::uxn::device_poke {port val} {
-  variable mode_2
-
-  if { $mode_2 } {
-    device_poke16 $port $val
-  } else {
-    device_poke8 $port $val
-  }
-  callback $port $val
-}
-
 proc ::uxn::eval { pc } {
   variable ram
   variable program
@@ -426,8 +510,6 @@ proc ::uxn::eval { pc } {
   variable dev
   variable src
   variable dst
-  variable rst
-  variable wst
 
   log "loaded program size: [llength $program]"
 
@@ -466,13 +548,22 @@ proc ::uxn::eval { pc } {
 
     switch $name {
       BRK { return 1 }
-      INC { push [ expr [pop] + 1 ] }
+      STZ -
+      STZ2 { poke [stack_pop8 $src] [pop] }
+      JCI { if { ![stack_pop8 $src] } { set pc [move 2 $pc] } }
+      JSI { stack_push16 rst [expr $pc + 2]; set pc [move [expr [peek16 $pc] + 2] $pc] }
+      INC -
+      INC2 { push [ expr [pop] + 1 ] }
+      DEI -
+      DEI2 { push [device_peek [stack_pop8 $src]] }
       DEO -
-      DEO2 { device_poke [stack_pop8 $src ] [pop] }
+      DEO2 { device_poke [stack_pop8 $src] [pop] }
       LIT -
       LIT2 -
       LITr -
       LIT2r { push [peek $pc]; set pc [move [expr !!$mode_2 + 1] $pc] }
+      SFT -
+      SFT2 { set a [stack_pop8 $src]; set b [pop]; push [expr $b >> ($a & 0x0f) << (($a & 0xf0) >> 4)] }
     }
   }
 }
\ No newline at end of file
diff --git a/test/hello-pixels.tal b/test/hello-pixels.tal
new file mode 100644
index 0000000..7dc6c36
--- /dev/null
+++ b/test/hello-pixels.tal
@@ -0,0 +1,27 @@
+( hello-pixels.tal )
+
+( devices )
+|00 @System  [ &vector $2 &pad $6 &r $2 &g $2 &b $2 ]
+|20 @Screen  [ &vector $2 &width $2 &height $2 &pad $2 &x $2 &y $2 &addr $2 &pixel $1 &sprite $1 ]
+
+( macros )
+%DRAW-PIXEL { #41 .Screen/pixel DEO } ( -- )
+%INC-X { .Screen/x DEI2 INC2 .Screen/x DEO2 } ( -- )
+
+( main program )
+|0100
+      #2ce9 .System/r DEO2
+      #01c0 .System/g DEO2
+      #2ce5 .System/b DEO2
+
+      ( set initial x,y coordinates )
+      #0008 .Screen/x DEO2
+      #0008 .Screen/y DEO2
+
+      ( draw 6 pixels in an horizontal line )
+      DRAW-PIXEL INC-X
+      DRAW-PIXEL INC-X
+      DRAW-PIXEL INC-X
+      DRAW-PIXEL INC-X
+      DRAW-PIXEL INC-X
+      DRAW-PIXEL
\ No newline at end of file
-- 
2.45.2