sid/component/lcd/hw-visual-lcd.tk

   1 # Copyright (C) 2000 Red Hat
   2 #
   3 # A simple tk-based LCD display component
   4
   5 variable row_col_pin
   6 set row_col_pin [sid::pin::new]
   7
   8 variable frame_pin
   9 set frame_pin [sid::pin::new]
  10
  11 variable attributes
  12
  13 #default attribute values - width is 20 cols by 8 pixels/col by 4 bits/pixel
  14 set attributes(bits_per_pixel) 4
  15 set attributes(width) [expr 20*8*4]
  16 set attributes(height) [expr 4*8*4]
  17
  18 frame .screen -relief groove -borderwidth 4
  19 pack .screen -side top
  20
  21 canvas .screen.c
  22 pack .screen.c
  23
  24 proc find_pin {name} {
  25     variable row_col_pin
  26     variable frame_pin
  27
  28     if {$name == "row-col" } { return $row_col_pin }
  29     if {$name == "FR" } { return $frame_pin }
  30     return ""
  31 }
  32
  33 proc attribute_names {} {
  34     variable attributes
  35     return [list "width" "height" "bits-per-pixel" "background-color"]
  36 }
  37
  38 proc attribute_names_in_category {cat} {
  39     if {$cat == "setting"} then {
  40         return [list "width" "height" "bits-per-pixel" "background-color"]
  41     }
  42
  43     return [list]
  44 }
  45
  46
  47 proc set_attribute_value {attr value} {
  48      variable attributes
  49
  50      if {$attr == "width"} then {
  51          set size [expr $value * $attributes(bits_per_pixel)]
  52          set attributes(width) $size
  53          .screen.c configure -width $size
  54          return "ok"
  55      }
  56
  57      if {$attr == "height"} then {
  58          set size [expr $value * $attributes(bits_per_pixel)]
  59          set attributes(height) $size
  60          .screen.c configure -height $size
  61          return "ok"
  62      }
  63
  64      if {$attr == "bits-per-pixel"} then {
  65          set attributes(bits_per_pixel) $value
  66          return "ok"
  67      }
  68
  69      if {$attr == "background-color"} then {
  70          .screen.c configure -background $value
  71          return "ok"
  72      }
  73
  74      return "not_found"
  75 }
  76
  77 proc attribute_value {attr} {
  78      variable attributes
  79
  80      if {$attr == "width"} then {
  81          return $attributes(width)
  82      }
  83
  84      if {$attr == "height"} then {
  85          return $attributes(height)
  86      }
  87
  88      if {$attr == "bits-per-pixel"} then {
  89          return $attributes(bits_per_pixel)
  90      }
  91
  92      if {$attr == "background-color"} then {
  93          # return just the '#rrggbb' at the end
  94          set lbg [split [.screen.c configure -background]]
  95          return [lindex $lbg [expr [llength $lbg] - 1]]
  96      }
  97
  98      return ""
  99 }
 100
 101 proc connect_pin {name pin} { return "not_found" }
 102 proc disconnect_pin {name pin} { return "not_found" }
 103 proc connected_pins {name} { return "" }
 104 proc find_bus {name} { return "" }
 105 proc connect_accessor {name bus} { return "" }
 106 proc connected_bus {name} { return "" }
 107
 108 proc set_pixel {args} {
 109     variable attributes
 110
 111     set val $args
 112     set bpp $attributes(bits_per_pixel)
 113     set rowp [expr ($val >> 16) * $bpp]
 114     set colp [expr ($val & 0xffff) * $bpp]
 115
 116     .screen.c create rectangle $colp $rowp \
 117                         [expr $colp+($bpp-1)] [expr $rowp+($bpp-1)] \
 118                         -fill black
 119 }
 120
 121 proc new_frame {arg} {
 122     if {$arg == 1} then {
 123         .screen.c delete all
 124     } else {
 125         update
 126     }
 127 }
 128
 129 proc driven_h4 {pin value} {
 130     variable row_col_pin
 131     variable frame_pin
 132
 133     if {$pin == $row_col_pin} then { set_pixel $value }
 134     if {$pin == $frame_pin} then { new_frame $value }
 135 }
 136
 137 update