waveform.m 7.22 KB
Newer Older
bp's avatar
bp committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
#! xbigforth
\ automatic generated code
\ do not edit

also editor also minos also forth

component class wave-form
public:
  infotextfield ptr distance
  hscaler ptr steps-x
  hviewport ptr switches
  button ptr wave-flip
  button ptr #load
  viewport ptr wave-s
  button ptr wave-space
 ( [varstart] ) cell var wave-x
cell var wave-y
cell var step-x
cell var time-x
cell var waves
cell var preamble
cell var file-name
canvas [] waveforms
method add-wave
method >wave-name
method init-waves
method show-waves
method wave-file
method step-act
method set-dist ( [varend] ) 
how:
bp's avatar
bp committed
32
  : params   DF[ 0 ]DF X" Waveform Viewer" ;
bp's avatar
bp committed
33 34 35 36 37 38 39
class;

component class about-w
public:
  button ptr i-see
 ( [varstart] )  ( [varend] ) 
how:
bp's avatar
bp committed
40
  : params   DF[ i-see self ]DF X" About Waveform Viewer" ;
bp's avatar
bp committed
41 42 43 44 45 46 47
class;

component class help-w
public:
  button ptr help-ok
 ( [varstart] )  ( [varend] ) 
how:
bp's avatar
bp committed
48
  : params   DF[ help-ok self ]DF X" Waveform Help" ;
bp's avatar
bp committed
49 50 51 52 53
class;

help-w implements
 ( [methodstart] )  ( [methodend] ) 
  : widget  ( [dumpstart] )
bp's avatar
bp committed
54 55 56 57
          X" Left button: set/drag&drop red line" text-label new 
          X" Rigth button: set/drag&drop blue line" text-label new 
          X" Both/middle buttons: switch between dec/hex" text-label new 
          X" +/- switch: show/hide wave" text-label new 
bp's avatar
bp committed
58
            $10 $1 *hfill $10 $1 *vfill glue new 
bp's avatar
bp committed
59
            ^^ S[ close ]S ( MINOS ) X"  OK " button new  ^^bind help-ok
bp's avatar
bp committed
60
            $10 $1 *hfill $10 $1 *vfill glue new 
bp's avatar
bp committed
61 62 63
          #3 hatbox new #1 vskips
        #5 vabox new
      #1 vabox new panel
bp's avatar
bp committed
64 65 66 67 68 69
    ( [dumpend] ) ;
class;

about-w implements
 ( [methodstart] )  ( [methodend] ) 
  : widget  ( [dumpstart] )
bp's avatar
bp committed
70 71 72
          X" Waveform viewer" text-label new 
          X" (c) 1997-1999 by Bernd Paysan/Mixed Mode" text-label new 
          X" Written with bigFORTH/MINOS" text-label new 
bp's avatar
bp committed
73
            $10 $1 *hfilll $10 $1 *vfil glue new 
bp's avatar
bp committed
74
            ^^ S[ close ]S ( MINOS ) X" I see" button new  ^^bind i-see
bp's avatar
bp committed
75 76 77 78 79 80
            $10 $1 *hpix $10 $1 *vfill glue new 
            ^^ S[ [IFDEF] win32
0" bigforth ##include genwave.fs >file wave.trc $2000 genwave eot bye"
[ELSE]
0" bigforth genwave.fs -e '>file wave.trc $2000 genwave eot bye'"
[THEN]
bp's avatar
bp committed
81
[ also dos ] system [ previous ] drop ]S ( MINOS ) X" Generate Test Pattern" button new 
bp's avatar
bp committed
82
            $10 $1 *hfilll $10 $1 *vfil rule new 
bp's avatar
bp committed
83 84 85
          #5 habox new #1 vskips
        #4 vabox new
      #1 vabox new panel
bp's avatar
bp committed
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
    ( [dumpend] ) ;
class;

include wave-form.fs
wave-form implements
 ( [methodstart] ) also dos also memory also
: add-wave ( n i -- )
  waveforms with waveform add-wave  endwith ;
: >wave-name ( addr u i -- )  waveforms text! ;
: ?preamble ( -- )
  preamble @
  IF  source dup preamble @ !
      tuck preamble @ cell+ @+ + swap move
      preamble @ cell+ +!  THEN ;
: >wave-names ( -- )
  preamble @ @ negate preamble @ cell+ +!
  preamble @ 2@ / dup NewPtr preamble @ @ cells NewPtr
  { u addr idx |
    0 preamble @ @+ @+ + over - -rot 0
    ?DO  over I + c@ bl <> IF  I over cells idx + ! 1+  THEN
    LOOP  2drop
    waves @ 0 ?DO
       preamble @ @+ cell+
       u 0 ?DO  dup idx J cells + @ + c@ addr I + c! over +
          LOOP 2drop
       addr u bl skip I >wave-name
     LOOP addr DisposPtr idx DisposPtr }
  preamble HandleOff ;
: init-waves ( n -- ) ^>^^ dup waves !
  0 ?DO ( Ith )  S" "  LOOP
  waves @ waveform new[] bind[] waveforms ;
: wave-file ( addr u -- )  base push hex
  r/o open-file throw $4000 input-file
  only previous scan-it
  preamble @ IF  preamble HandleOff  THEN
  $4000 preamble Handle!  0. preamble @ 2!
  BEGIN  refill  WHILE
      bl word count 2dup + 1- c@ ': =
      IF
          time-x @ 0= IF  1- decimal s>number drop time-x !
          ELSE  2drop  THEN
          F depth >r hex interpret F depth r> -
          waves @ 0= IF  init-waves >wave-names
          ELSE  dup waves @ <>
              IF  ~~ 0 ?DO  drop  LOOP
                  ." Left because of wrong line in line "
                  F line @ . cr onlyforth
                  loadfile @ close-file deltib throw  EXIT
              THEN
              drop
          THEN
          waves @ 1-
          FOR  I add-wave  NEXT
      ELSE
          2drop ?preamble
      THEN
  REPEAT
  preamble @ IF  preamble HandleOff  THEN
  loadfile @ close-file throw onlyforth
  ( ." finished" cr ) ;
: forget-waves ( -- )
  link[] waveforms cell- dup @ 1+ cells dispose,  waves off ;
: dispose ( -- )
  file-name @  IF  file-name HandleOff  THEN
  forget-waves  super dispose ;
: step-act ( -- actor )
bp's avatar
bp committed
152
  ^ 0 #30 :[ step-x ! !resized resized ]:
bp's avatar
bp committed
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
  scale-do new scale-do with  4 pos ! ^ endwith ;
: show-waves ( -- )  ^>^^
  0 BEGIN  dup waves @ <  WHILE
         dup waveforms self dup >r
         0 1 *fill 2dup glue new  2 habox new
      vxrtsizer new  2 vasbox new
      dup -1 combined ' +flip combined ' -flip
      toggle new r> waveform with comment $@ endwith TT-string
      '+ '- togglechar new >r
      swap 1+
  REPEAT
  0 1 *fill 2dup glue new  swap 1+
  vabox new \ 1 vskips
  wave-s assign
  0 BEGIN  dup waves @ <  WHILE
      1+ r> over -roll
  REPEAT
  habox new \ hfixbox 1 vskips
  switches assign ;
: create-waves ( addr u -- )  ^>^^
  ['] wave-file catch  ?dup  IF  onlyforth throw  THEN
  show-waves ;
: show-load ( -- )
  old-file @ IF  old-file $@  ELSE  s" wave.trc"  THEN
  file-name $!
  s" Load Wave File"
  old-file @ IF  old-file $@  ELSE  s" "  THEN
  old-path @ IF  old-path $@  ELSE  s" *.trc"  THEN
  ^ S[ 2over 2swap path+file
       2dup 2dup '/ -scan nip /string old-file $!
       file-name $!  old-path $!
       file-name $@ dpy with window title! endwith
       file-name $@ create-waves dpy !resized
       s" Reload" #load assign ]S fsel-dialog ;
: show ( -- )  super show
bp's avatar
bp committed
188
  #800 #600 dpy geometry ;
bp's avatar
bp committed
189 190 191 192 193
: set-dist ( -- ) \ distance get d0= >r
  wave-y @ wave-x @ - time-x @ m* distance assign ;
previous previous previous ( [methodend] ) 
  : widget  ( [dumpstart] )
              $10 $1 *hfill $0 $1 *vfill glue new 
194
              #0. ]N ( MINOS ) ^^ SN[  ]SN ( MINOS ) X" Steps" infotextfield new  ^^bind distance
bp's avatar
bp committed
195
              $10 $1 *hfill $0 $1 *vfill glue new 
bp's avatar
bp committed
196
            #3 vabox new hfixbox  #1 hskips
bp's avatar
bp committed
197
              $10 $1 *hfill $0 $1 *vfill glue new 
bp's avatar
bp committed
198
              ^^ #4 #28 SC[ step-x @ over step-x ! <> IF  dpy !resized  THEN ]SC ( MINOS ) hscaler new  ^^bind steps-x #-20 SC# 
bp's avatar
bp committed
199 200
              $64 $1 *hfil $0 $1 *vfil glue new 
              $10 $1 *hfill $0 $1 *vfill glue new 
bp's avatar
bp committed
201 202
            #4 vabox new hfixbox  #1 hskips
          #2 habox new hfixbox 
bp's avatar
bp committed
203
            1 1 hviewport new  ^^bind switches DS[ 
bp's avatar
bp committed
204 205 206 207 208
              ^^ S[  ]S ( MINOS ) X" +-" button new  ^^bind wave-flip
            #1 habox new ]DS ( MINOS ) 
          #1 habox new
            ^^ S[ about-w dialog ]S ( MINOS ) X" About" button new 
            ^^ S[ help-w dialog ]S ( MINOS ) X" Help" button new 
bp's avatar
bp committed
209
            ^^ S[ file-name @ 0= IF  show-load
bp's avatar
bp committed
210 211 212
ELSE  waves off file-name $@ create-waves !resized  THEN ]S ( MINOS ) X" Load" button new  ^^bind #load
          #3 hatbox new hfixbox  panel
        #3 habox new vfixbox 
bp's avatar
bp committed
213
        1 1 viewport new  ^^bind wave-s DS[ 
bp's avatar
bp committed
214 215 216 217 218
              ^^ S[  ]S ( MINOS ) X" Waves" button new  ^^bind wave-space
            #1 vabox new
          #1 vabox new
        #1 habox new ]DS ( MINOS ) 
      #2 vabox new
bp's avatar
bp committed
219 220 221 222 223
    ( [dumpend] ) ;
class;

: main
  wave-form open-app
bp's avatar
bp committed
224
  event-loop bye ;
bp's avatar
bp committed
225 226
script? [IF]  main  [THEN]
previous previous previous