home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 067.lha / Drw / drw.4th < prev    next >
Text File  |  1986-11-20  |  25KB  |  1,165 lines
  1. \ Draw yer freqencies and synthesize em
  2. \
  3. \ get the binary speedy sin,cosine
  4. Find Qsin.Spot Not IFTrue Include Qsin IfEnd
  5. \ get 8SVX maker?
  6. find 8svxmake.spot not IFTrue Include 8SVXMAke IFEnd
  7. \ console support pack
  8. find Consupp.spot not IFTrue Include Consupp IFEnd
  9. \
  10. \
  11. Decimal
  12. \
  13. 15000 Minimum.Object
  14. 512 tokens
  15. anew Drw.spot
  16. \
  17. 512 4 1array Accum
  18. 256 4 1array Phase
  19. \
  20. Variable N'p   \ number of points in the record
  21. Variable WN'p   \ working number of points in the record
  22. Variable WN'x   \ working number of points in the record multiple
  23. Variable K     \ Bitwise resolution 
  24. \ Drw Loop Parms...
  25. Variable B'Zd \ sample Delta
  26. Variable B'Ze \ sample end
  27. Variable B'Fs \ Low Freq  ( as phase shift )
  28. Variable B'Fe \ HighFreq  ( ditto )
  29. Variable B'Fd \ Freq delta ( = H-l/128 ) 
  30. Variable F'Sz \ Size of the in-core block (64K)
  31. Variable B'Zs \ BPF start
  32. Variable B'Fk \ skip number for BPF
  33. variable f'oct \ OCtaves for the file
  34. \
  35. Variable Shutup
  36. Variable Played?
  37. Variable Button
  38. Variable Period
  39. variable ccolor
  40. Variable CDrmode
  41. Variable HowLoud
  42. \
  43. hex 68 wconstant MDOWN        \ these are returned in event message
  44.     E8 wconstant MUP decimal
  45. \
  46. Variable Dl'x
  47. Variable Dl'y
  48. \ 
  49. Variable T'f \ working frequency
  50. Variable T's \ sum register
  51. Variable T'c \ sum register
  52. Variable I'  \ other index
  53. variable LoopIx \ drawing loop indicies
  54. Variable Flock \ frequency lock
  55. \
  56. Variable Fl'S \ floating scale...
  57. Variable Fid \ file id for BPF
  58. Variable BackX \ backup feature...
  59. Variable Backy \ backup feature...
  60. Variable CbaseXA \ Copy base
  61. Variable CbaseXB \ Copy base
  62. Variable CbaseYA \ Copy base
  63. Variable CbaseYB \ Copy base
  64. \ 
  65. 256 Constant Bwid 
  66. 128 Constant BHei 
  67. 30 Constant Bdown 
  68. Bdown 129 + Constant Bdown' 
  69. Bdown 128 + Constant Bdown'' 
  70. 5  Constant BLeft 
  71. Bleft 1+  Constant BLeft' 
  72. Bleft Bwid + Constant Bright
  73. \ loopix box
  74. bright 5+ Constant L'Left
  75. l'left 10 + constant l'right
  76. bdown constant L'top
  77. bdown  40 + constant l'bot
  78.  
  79.  
  80. \ 
  81. \ define a custom screen, use defaults
  82. \
  83. Create DrwSTitle
  84. 0," Hey! I'm Dressing!"
  85. Create DrwWTitle
  86. 0," Drw Window"
  87. struct NewScreen DrwNs
  88.     DrwNs InitScreen     \ copy default values to new screen
  89. 5   DrwNs +nsDepth W!
  90. 320 DrwNs +nsWidth W!
  91. 0   DrwNs +NsViewModes W!
  92. struct NewWindow DrwNw \ define a window
  93.          Drwnw InitWindow      \ copy default values to new window
  94.       0  Drwnw +nwLeftEdge w!
  95.       0  Drwnw +nwTopEdge  w!
  96.      320 Drwnw +nwWidth    w!
  97.      200 Drwnw +nwHeight   w!
  98.  WINDOWSIZING WINDOWDRAG  | WINDOWCLOSE | ACTIVATE | 
  99.                       Drwnw +nwFlags !
  100.      fCLOSEWINDOW MouseButtons |  
  101.      RawKey |         Drwnw +nwIDCMPFlags  !
  102.      CUSTOMSCREEN     Drwnw +nwType w!  \  open on a custom screen
  103. structend
  104. \
  105. Variable MODE
  106. \
  107. create TopMode$
  108. 0," D R W -  D S P  R B  W  I O  Q "
  109. create DoodleMode$
  110. 0," Doodle Mode "
  111. create SynthMode$
  112. 0," Synth Mode "
  113. create PlayMode$
  114. 0," Play Mode " 
  115. create WriteMode$
  116. 0," Write Mode " 
  117. create BPFMode$
  118. 0," Band Pass Mode " 
  119. create InputMode$
  120. 0," Input Mode " 
  121. create OutputMode$
  122. 0," Output Mode " 
  123. \
  124. : Curx Currentwindow @ +wMouseX W@
  125. ;
  126. : CurY Currentwindow @ +wMouseY W@
  127. ;
  128. : ClipX
  129. Dup BLeft < if drop bleft then
  130. Dup Bright > if drop Bright then
  131. ;
  132. : ClipY
  133. dup bdown < if drop bdown then
  134. dup bdown' > if drop bdown' then 
  135. ;
  136. : CurX'
  137. CurX clipx
  138. ;
  139. : CurY'
  140. cury clipy
  141. ;
  142. Variable CX'
  143. Variable CY'
  144. variable Vx
  145. variable vy
  146. \
  147. Create T'Tx 8 allot
  148. T'Tx 8 erase
  149. : N'Text ( I X Y )
  150. Locals| YY XX II |
  151. II <# # # # # # # # # #> T'Tx swap Cmove
  152. Rport 2 SetAPen
  153. Rport XX yY Move
  154.  Rport T'Tx  8 Text drop
  155. ;
  156. : N'Text2 ( I X Y )
  157. Locals| YY XX II |
  158. II <# # # # #> T'Tx swap Cmove
  159. Rport 2 SetAPen
  160. Rport XX yY Move
  161.  Rport T'Tx  3 Text drop
  162. ;
  163. \
  164. : Asc, [compile] Ascii , ;
  165. ?align4
  166. create Xplan
  167. Asc, Dot_  Asc, Line  asc, Ramp  asc, Thin  asc, Blob
  168. asc, Harm  Asc, Avg_  asc, R-Up  asc, R-Dn  asc, Fill
  169. asc, Fil2  asc, Dec_  asc, Inc_  asc, Xcld  asc, -Cut
  170. Asc, Dec0  asc, Inc0  asc, From  asc, To__  asc, Copy
  171. asc, .21.  asc, AMmd  asc, CpFr  asc, CpTm  asc, Lck1
  172. asc, Lck2  asc, Lck4  asc, Lck8  asc, Vl02  asc, Vl01
  173. asc, Vl00  asc, .32. 
  174. : getCmode 
  175. Cury 25 < If
  176. Curx Bleft - 4 / 32 min  1 Max cdrmode ! 
  177.  cdrmode @ 280 20 N'text2
  178. rport 240 20 Move
  179. Rport 2 setapen
  180. Rport CdrMode @ 1- 4* Xplan + 4 Text drop 
  181. Rport CColor @ Setapen \ goldarn ntext busted it
  182. Mup Button !
  183. then
  184. ;
  185. : compcm
  186. CdrMode @  4* bleft + Locals| XX |
  187. Rport 2 SetDrMd
  188. Rport xx 18 xx 3+ 23 RectFill
  189. Rport 1 setdrmd
  190. ;
  191. \ Trace on
  192. : LoopixShow
  193. Loopix @ l'bot + 5- 
  194. Locals| Me  |
  195. Rport 2 setDrMd
  196. rport l'left me move
  197. rport l'right me draw
  198. rport 1 setdrmd
  199. Loopix @ negate 280 40 N'Text2
  200. ;
  201. : GetLoopix
  202. curx l'left l'right range swap drop  if
  203. \ oh boy: in range!
  204. LoopixShow
  205. cury 5+ l'bot -  -31 max -1 min loopix !
  206. loopixshow
  207. then
  208. ;
  209. : getccolor?
  210. Cury 17 < If
  211. curx bleft - 4 / 31 min 1 max  ccolor !
  212. Rport CColor @ SetAPen
  213. Rport 140 12  160 23 RectFill
  214. Mup Button !
  215. Else
  216. CompCM
  217. GetCmode
  218. CompCm
  219. then
  220. \ how bout somothose funny parms?
  221. Cury bleft 30 - > If
  222. GetLoopix
  223. then
  224. ;
  225. \
  226. : EventPoll ( -- t/f ) \ true if any button hit
  227.    GetEvent
  228.    Case
  229. MouseButtons Of ThisEvent  +eCode W@ Button ! false
  230. Mode @ 1 = if
  231. Button @ Mdown = If getccolor?  else BackX Off Backy off then 
  232. then
  233.  Endof
  234. RawKey OF
  235.    ThisEvent +ecode W@ 
  236.     Case
  237. [ hex ]
  238.  22 of 1 Mode ! true endof \ D fer doodle
  239.  21 of 2 Mode ! true endof \ s fer Synth
  240.  19 of 3 Mode ! true endof \ p fer Play
  241.  14 of 4 Mode ! true endof \ t fer Top
  242.  10 of 5 Mode ! true endof \ Q fer Quit
  243.  11 of 6 Mode ! true endof \ W for Write
  244.  35 of 7 Mode ! true endof \ B for BPF
  245.  13 of 8 Mode ! true endof \ R for Reset
  246.  17 of 9 Mode ! true endof \ I for input screen
  247.  18 of 0A Mode ! true endof \ O for output screen
  248. [ decimal ] false
  249.     endcase
  250.     EndOf
  251. fCLOSEWINDOW Of
  252. \ ." CW "
  253.   5 mode ! true Endof
  254. \ elsssee....
  255.  false 
  256.    Endcase
  257. ;
  258. Create FileName$ 41 allot 
  259. Variable F'
  260. \
  261.  
  262. : GNum ( -- # ) \ read a # from keyboard
  263. Begin 10 ask.Number until
  264. ;
  265. : GetFileName 
  266. cr ." Filename?"
  267. FileName$ 40 expect 
  268. 0 FileName$ Cnt @ 1- + C!
  269. cr
  270. ;
  271. Create DrwConname
  272. 0," CON:10/10/300/150/D R W Input screen"
  273. variable rf'sz
  274. : GetBpfFileName 
  275. CurrentScreen @ ScreentoBack
  276. DRWCOnName ZapDosCon
  277. begin
  278. cr ." Filename of a sound file?"
  279. FileName$ 40 expect 
  280. 0 FileName$ Cnt @ 1- + C!
  281. FileName$ Open ?Dup 
  282. 0= if ." Can't find that file??" cr false
  283. else fid ! true then
  284. until
  285. \ other bpf stuff
  286. ." Sample start:" GNum B'Zs !
  287. B'Zs @ B'Zd @ 8 scale +  F'sz @ Min  B'Ze !
  288. ." K           :" Gnum K !
  289. 1 k @ Scale  N'p !
  290. fid @ filesize?  65536 Min RF'sz !
  291. \ Read the sucker into the sound array...
  292. F' @@ RF'Sz @ 0 Fid @ Read.Virtual
  293. Fid @ Close
  294. UnzapDosCon
  295. CurrentScreen @ ScreenToFront
  296. ;
  297.  
  298. \
  299. Decimal
  300. : BigBegin
  301. Shutup off
  302. Mode Off
  303. 2 ccolor !
  304. 3  CdrMode !
  305. -1 loopIx !
  306. -10 HowLoud !
  307. 1 flock !
  308. \ defaults for sampling
  309. 128 B'Zd ! 
  310. B'Zd @ 8 scale B'ze !
  311. 512 B'FD !
  312. 4096 B'Fs !
  313. BackX Off
  314. BackY Off
  315. B'Fs @ B'Fd @ 7 scale + B'Fe !
  316. \ Size up the video pieces  256(x) by 128 (y)
  317. 65 1024 * F'SZ !
  318.  
  319. F'Sz @ Chip Get.Memory F' !
  320. F' @ 0= IF False else True Then
  321. ;
  322. decimal
  323. : GetDrwParms
  324. \ flip back the screen a spell...
  325. currentscreen @ Screentoback
  326. DRWConName  ZapDosCOn
  327. ."    Reset sample parms Mode... " cr
  328. ." Sample Delta(" B'Zd ? ." ):"   GNum 256 min 1 max B'Zd ! 
  329. B'Zd @ 8 scale   65536 Min  B'Ze !
  330. ."      Sample end is:" B'Ze ? cr
  331. ." Freq   Delta(" B'Fd ? ." ):"   Gnum b'Fd !
  332. ."        Delta in Hz:" b'fd @ 3523 * -15 scale . cr
  333. ." Freq   Start(" B'Fs ? ." ):" Gnum  B'Fs !
  334. ."        Start in Hz:"  B'Fs @ 3523 * -15 scale . cr
  335. B'Fs @ B'Fd @ 7 scale + B'Fe !
  336. ."    Freq End in Hz:" B'Fe @ 3523 * -15 scale . cr
  337. 50 delay 
  338. 3 mode !
  339. UnzapDosCon
  340. currentscreen @ screentofront
  341. \ tell 'e the current freq etc.
  342. B'Zd @ 20 190  n'text
  343. B'Fs @ 120 190 n'text
  344. B'FE @ 220 190 N'Text 
  345. ;
  346.  
  347. \
  348. create b> -4 allot  \ Code B>
  349. Hex
  350. 2017 w, \ d0 get,
  351. 4880 w, \ d0 byte ext,
  352. 48c0 w, \ d0 word ext,
  353. 2E80 w, \ d0 put,
  354. 361A W, 4eF6 W, 3018 W, \ next
  355. Decimal
  356. \ End-Code
  357. \
  358. { a forth version...
  359. Hex
  360. : B> ( byte extend )
  361.  FF and dup 7F > if FFFFFF00 + then
  362. ;
  363. Decimal
  364. }
  365. \
  366. \
  367. : okwindow?  ( -- )  currentwindow @ 0= if
  368.     currentscreen @ CloseScreen
  369.     cr ." unable to open window! " abort then ;
  370. \
  371.  : rgb \ r g b --n |     packs color values
  372.      swap 16* or swap 8 scale or ;  \ 16* is quick *, scale shifts bits
  373.  
  374. ?align
  375.  create ctable  \   table to store new colors
  376.  15 15 15 rgb w,  08 08 08 rgb w,  00 08 08 rgb w,  01 07 08 rgb w,
  377.  02 06 08 rgb w,  03 05 08 rgb w,  04 04 07 rgb w,  05 03 06 rgb w,
  378.  06 02 05 rgb w,  07 01 04 rgb w,  08 00 04 rgb w,  09 00 04 rgb w,
  379.  10 00 04 rgb w,  11 00 04 rgb w,  12 00 04 rgb w,  13 00 04 rgb w,
  380.  14 00 04 rgb w,  15 00 04 rgb w,  15 01 04 rgb w,  15 02 04 rgb w,
  381.  15 03 04 rgb w,  15 04 04 rgb w,  15 05 04 rgb w,  15 06 04 rgb w,
  382.  15 07 04 rgb w,  15 08 04 rgb w,  15 09 04 rgb w,  15 10 04 rgb w,
  383.  15 11 04 rgb w,  15 12 04 rgb w,  15 13 04 rgb w,  15 14 04 rgb w,
  384.  15 15 04 rgb w,
  385.  
  386.  : loadcolors  \  --   load new colors
  387.     currentwindow @ ViewPortAddress   \  get ViewPort address
  388.     ctable                            \   color table address
  389.     32                                \  number of colors to load
  390.     LoadRGB4 ;                        \ call to load color values
  391.  
  392. : PutUpScreen
  393. DrwSTitle DrwNs +nsDefaultTitle !
  394. DrwWTitle DrwNw +nwTitle !
  395.    DrwNs
  396.  OpenScreen
  397.  verifyscreen    \ open a 4 bit plane screen
  398.    CurrentScreen @ DrwNw  +nwScreen  ! \ store screen ptr in window
  399.    DrwNw OpenWindow okwindow?     \ open demo window
  400. \ set the colors
  401.  loadcolors
  402. ;
  403. \
  404. : ShutUpScreen
  405. Currentscreen @ ScreenTOBack
  406. CurrentWindow @ CloseWindow
  407. CurrentScreen @ CloseScreen
  408. \ Release GM space
  409. f' @ ?DUP IF  To.Heap then
  410. ;
  411. \
  412. Variable lennn
  413.  
  414. Decimal
  415. : N'Show ( Addr -- )
  416. Locals| Add |
  417. \ another display of the waveform
  418. \  Rport 1 setapen
  419. \  Rport bleft 180 17 -  Bright  180 17 + Rectfill
  420.  256 0 DO
  421. rport 1 setapen
  422.  rport bleft I+ 163 move
  423.  rport bleft I+ 197 draw
  424.  Rport 31 SetAPen
  425. Rport  Bleft I+ 
  426. Add I+ C@ B>  -3 scale 180 +   WritePixel \ draw
  427. Loop
  428. ;
  429. Hex
  430. : EndGame \ now quasi stereo
  431. 0 Locals| U- | 
  432. Button @ Mdown = IF
  433. Played? On
  434. F' @@  dup DFF0A0 ! DFF0B0 !
  435. B'Ze @ 2/ dup DFF0A4 W! DFF0B4 W!
  436.  CurrentWindow @ +wMouseY W@ 2* 7c + 7c Max  dup DFF0A6 W!  DFF0B6 W! \ period
  437. \ CurrentWindow @ +wMousex W@  7c + 7c Max   DFF0B6 W!  \ period
  438. 3f Dff0A8 W! \ loudness
  439. 3f Dff0B8 W! \ loudness
  440. \ fire away..
  441. 8203 Dff096 W! \ start DMA
  442. else
  443. \
  444. Played? @ If
  445.    3 Dff096 W! \ Stop DMA
  446. Then
  447. Played? Off
  448. then
  449.  \
  450. ;
  451. Decimal
  452. : PlayMode
  453. CurrentWindow @ PlayMode$ -1 SetWindowTitles
  454. Shutup off
  455. Begin
  456. \ display "mouse std freq in Hz (freq of a b'fd sized record)"
  457.  CurrentWindow @ +wMouseY W@ 2* 124 + 124 Max  170 20 n'text
  458. Endgame
  459. eventPoll Mode @ 3 = not and
  460. until
  461. ;
  462. : TopMode
  463. 0 0 locals| Z  aa |
  464. CurrentWindow @ TopMode$ -1 SetWindowTitles
  465. 32 1 do
  466. Rport I SetAPen
  467. Rport BLeft I 4* +  12  BLeft I 1+ 4* + 1- 16 RectFill
  468. loop
  469. \ move the comb over
  470.  33 1 do
  471. rport 1 setapen
  472. Rport Bleft I  4* +   17  bleft I 1+ 4* + 1- 23 Rectfill
  473. rport 12 setapen
  474. Rport Bleft I  4* + 1+  17  bleft I 1+ 4* + 2- 23 Rectfill
  475. loop
  476. CompCm
  477. \ draw the box
  478. Rport 1 setApen
  479. Rport BLeft Bdown  Bright    Bdown Bhei + 1+   RectFill
  480. \ tell 'e the current freq etc.
  481. B'Zd @ 20 190  n'text
  482. B'Fs @ 120 190 n'text
  483. B'FE @ 220 190 N'Text 
  484. \ draw the loopix box
  485. rport l'left l'top l'right l'bot Rectfill
  486. rport 16 setapen
  487. rport l'left l'top move
  488. rport l'left l'bot draw
  489. rport l'right l'bot draw
  490. rport l'right l'top draw
  491. rport l'left  l'top draw
  492. rport 1 setapen
  493. LoopixShow
  494. Loopix @ negate 280 40 N'Text2
  495. rport ccolor @ setapen
  496. 1 mode !
  497. ;
  498. Decimal
  499.  
  500. : writeMode \ actually attempts to write 8SVX IFF file
  501. CurrentWindow @ WriteMode$ -1 SetWindowTitles
  502. CurrentScreen @ ScreentoBack
  503.  drwconname ZApdoscon
  504. Getfilename
  505. ." Number Of Octaves??"  Gnum 1 max 7 min f'Oct !
  506. ." Favorite Period (124-999)?"  Gnum 124 max 999 min 3579546 swap / 8Hertz !
  507.  
  508.  f' @@ B'Ze @ F'Oct @ Filename$  8svxMake 
  509. if cr ." Successfully created!"  else
  510.    cr ." Sorry, couldn't write it!" then 30 delay
  511.  unzapdoscon
  512. CurrentScreen @ ScreenToFront
  513. 3 mode !
  514. ;
  515.  
  516. \
  517. Variable zpot
  518. Variable Pimp
  519. Variable BLIP ascii Blip blip !
  520. \
  521. : full@
  522. pimp  4  zpot @ Fid @ read.virtual
  523. 4 Zpot +! pimp @
  524. ;
  525. : full!
  526.  4  zpot @ Fid @ write.virtual
  527. 4 zpot +!
  528. ;
  529. \ structure for file: ID, time width,
  530. \ frq lo, frq width, (samples)
  531. \
  532. : InputMode \ read screen file..
  533. CurrentWindow @ InputMode$ -1 SetWindowTitles
  534. CurrentScreen @ ScreentoBack
  535. drwconname ZapDosCon
  536. ." Input a Screen File " cr
  537. begin
  538. Getfilename
  539. Filename$ open dup fid !
  540. 0= if ." Can't find it! " cr then
  541. fid @ 0= not until
  542. UnzapDosCOn
  543. CurrentScreen @ ScreenToFront
  544. zpot off
  545. \ get ye parms
  546.  full@ blip @ = if
  547. full@  B'zd !
  548. B'Zd @ 8 scale   65536 Min  B'Ze !
  549. full@  b'fs !
  550. full@  b'fd !
  551. B'Fs @ B'Fd @ 7 scale + B'Fe !
  552. \ now read em
  553. f' @@ f'sz @ zpot @ fid @ read.virtual
  554. fid @ close
  555. \ now show it
  556. 256 0 do
  557. I 170 20 n'text
  558.  128  0 do
  559. rport  j 7 scale i+ f' @@ + C@ setapen
  560. rport bleft j + bdown i+ writepixel
  561. loop
  562. loop 
  563. else
  564. ." That wasn't a good screen file " cr
  565. fid @ close
  566. then
  567. 3 mode !
  568. \ tell me the current freq etc.
  569. B'Zd @ 20 190  n'text
  570. B'Fs @ 120 190 n'text
  571. B'FE @ 220 190 N'Text 
  572. ;
  573. : OutputMode \ write screenfile
  574. CurrentWindow @ OutputMode$ -1 SetWindowTitles
  575. CurrentScreen @ ScreentoBack
  576. drwconname ZapDosCon
  577. ." Output screen file name:" Cr
  578. Getfilename
  579. UnzapDoscon
  580. CurrentScreen @ ScreenToFront
  581. \ open it for write..
  582. filename$ new.file fid !
  583. fid @ 0= not if
  584. zpot off
  585. blip full!
  586. b'zd Full!
  587. b'fs full!
  588. b'fd full! 
  589. \ now read off those pixels into f'
  590. 256 0 do
  591. I 170 20 n'text
  592.  128 0 do 
  593. rport Bleft j + bdown i+ readpixel
  594. j 7 scale i+ f' @@ + C!
  595. loop
  596. loop 
  597. \ now write f'
  598. f' @@ f'sz @ zpot @ fid @ write.virtual
  599. fid @ close
  600. else
  601. ioerror? @
  602. ." couldn't open it: code:" . cr
  603. then
  604. 3 mode !
  605. ;
  606. \
  607. VAriable Tharm
  608. Variable Ty
  609. Variable Lx
  610. Variable Px'
  611. Variable Py'
  612. Variable Rx
  613. Variable Lcol
  614. Variable Rcol
  615. \
  616. : doodleMode
  617. 0 Locals| Temp  |
  618. CurrentWindow @ DoodleMode$ -1 SetWindowTitles
  619. begin
  620. Curx Cx' !
  621. CurY' FLock @ w/ FLock @ W* CY' !
  622. CY' @ Bdown  bdown' range  swap drop 
  623. Cx' @ Bleft bright Range swap drop and IF
  624. bdown' Cy' @ - B'fd @ * b'Fs @ + 3523 * -15 scale 170 20 n'text 
  625. cx' @ clipx Cx' !
  626. Button @ MDown = If
  627. rport ccolor @ setapen
  628. Cdrmode @
  629. Case
  630. 1 of \ mode 1 = just draw, fella
  631. Rport CX' @ clipx CY' @ writePixel
  632. endof
  633. 2 of \ draw via line, bub
  634. Cx' @ BAckX @ > IF
  635. cx' @ 1+ BackX !
  636. rport vx @  Clipx vy @ move
  637. Rport CX' @ clipx   CY' @  clipy DRaw
  638. cx' @ vx !
  639. cy' @ vy !
  640. then
  641. endof
  642. 3 of \ ramp draw- add
  643. CX' @ BackX @ > If
  644. cx' @ 1+ BackX !
  645. CColor @ to Temp
  646. 0 I' !
  647. 2 Temp  do
  648. Cx' @ I' @ -  Clipx Lx !
  649. Rport Lx @ Cy' @ readPixel i+ 31 min
  650. Rport swap SetApen
  651. Rport Lx @ Cy' @ WritePixel
  652. Cx' @ I' @ +  Clipx dup lx @ = if drop else
  653. Lx !
  654. Rport Lx @ Cy' @ readPixel i+ 31 min
  655. Rport swap SetApen
  656. Rport Lx @ Cy' @ WritePixel
  657. then
  658. 1 i' +!
  659.  LoopIx @  +loop
  660. then
  661. endof
  662. 4 of 
  663. Rport CX' @ clipx  CY' @ clipy  CX' @ 1+  clipx CY' @ 5+ clipy  RectFill
  664. endof
  665. 5 of 
  666. Rport CX' @ 3- clipx  CY' @ 3- clipy CX' @ 3+ clipx CY' @ 3+ clipy  RectFill
  667. endof
  668. 6 of \ HArmonix mode
  669. Cx' @ Backx @ > IF
  670. Backx @ 0= if cx' @ 1- backx ! cy' @ backy ! then 
  671. CX' @  BackX @ DO
  672. I PX' !
  673. \ interpolate Py from px
  674. I BackX @ - Cy' @ Backy @ - * Cx' @ BAckx @ - / Backy @ + Py' !
  675. \
  676. Bdown'  Py' @ -  B'fd @ *  B'fs @ + 8/ to temp \ CUrrent phase to temp
  677. Temp Tharm !
  678. BDown' Tharm @ B'Fs @ - B'Fd @ / - TY !
  679. \ cr ." harm: " temp . ." :"
  680. begin
  681. ty @ bdown' < If
  682.  0 i' !
  683.  2 ccolor @ do
  684.   Px' @ i' @ - clipx Lx !
  685.   Rport Lx @  Ty @ readPixel i+ 31 min 
  686.   rport swap setapen
  687.   Rport Lx @  Ty @ WritePixel \ write this one..
  688.   Px' @ i' @ + clipx dup lx @ = if drop else  Lx !
  689.    Rport Lx @ Ty @ ReadPixel  i+ 31 min
  690.   rport swap SetAPen
  691.   Rport Lx @ Ty @ WritePixel \ write this one..
  692.   then 
  693.   1 i' +!
  694.  Loopix @ +loop
  695. then
  696. Temp Tharm +!
  697. \ convert tharm to Ty
  698. BDown' Tharm @ B'Fs @ - B'Fd @ / - TY !
  699. \ ." (" Tharm @ . Ty @ . ." )"
  700. Ty @ Bdown <
  701. until
  702. loop
  703.  
  704. Cx' @  BackX !
  705. Cy' @  BackY !
  706.  
  707. then
  708. endof
  709. 7 of \ average mode
  710. 0 to Temp
  711.  3 -2 do
  712.  Rport Cx' @ I + clipx  Cy' @  ReadPixel temp + to Temp  
  713. loop
  714. rport temp 5 /  1 max setapen
  715. Rport Cx' @ 2- clipx  Cy' @  Cx' @ 2+ clipx  cy' @  RectFill
  716. endof
  717. 8 of \ smear forward
  718.  Rport Cx' @ Cy' @ ReadPixel to Temp
  719. 0 I' !
  720. 2 Temp  do
  721. Rport I SetApen
  722. Rport Cx' @ I' @ - dup bleft < if drop bleft then  Cy' @ WritePixel
  723. 1 i' +!
  724. LoopIx @ +loop
  725. rport ccolor @ Setapen 
  726. endof
  727. 9 of \ smear backward
  728.  Rport Cx' @ Cy' @ ReadPixel to Temp
  729. 0 I' !
  730. 2 Temp  do
  731. Rport I SetApen
  732. Rport Cx' @ I' @ + dup bright > if drop bright then  Cy' @ WritePixel
  733. 1 i' +!
  734. LoopIx @ +loop
  735. rport ccolor @ Setapen 
  736. endof
  737. 10 of \ FLOOD ( all with the same as x-y become Apen )
  738. rport cx' @ cy' @ readpixel to Temp
  739. \ search left..
  740. Cx' @ Dup Lx ! Rx !
  741. begin
  742. -1 Lx +!
  743. Rport Lx @ Cy' @ ReadPixel Temp = not 
  744. LX @ Bleft <  or
  745. until
  746. 1 Lx +!
  747. \ search right ..
  748. begin
  749. 1 rx +!
  750. Rport rx @ Cy' @ ReadPixel  Temp = not
  751. rX @ Bright >  or
  752. until
  753. -1 Rx +!
  754. \ redraw it
  755. Rport Lx @  cy' @ move
  756. Rport Rx @  Cy' @ Draw
  757. endof
  758. 11 of \ ramp this line up
  759. rport cx' @ cy' @ readpixel to Temp
  760. \ search left..
  761. Cx' @ Dup Lx ! Rx !
  762. begin
  763. -1 Lx +!
  764. Rport Lx @ Cy' @ ReadPixel dup Lcol ! Temp = not 
  765. LX @ Bleft < dup if 2 lcol ! then or
  766. Lcol @ 2 < or
  767. until
  768.  
  769. \ search right ..
  770. begin
  771. 1 rx +!
  772. Rport rx @ Cy' @ ReadPixel Dup Rcol ! Temp = not
  773. rX @ Bright > dup if 2 Rcol ! then or
  774. rcol @ 2 < or
  775. until
  776. \ ." Lx:" Lx ? ." Rx:" Rx ? ." Lcol:" Lcol ? ." Rcol:" rcol ? cr
  777.  
  778. \ redraw .left.
  779. cx' @ 1+ Lx @ do
  780.  rport Lcol @ 4* temp + 5 w/ dup Lcol ! Setapen
  781. Rport I Cy' @ WritePixel
  782. 1 +loop
  783. \ redraw right
  784. cx' @  rx @ 1+ do
  785.  rport rcol @ 4* temp + 5 / dup rcol ! Setapen
  786. Rport I Cy' @ WritePixel
  787. -1 +loop
  788.  
  789. Rport ccolor @ Setapen \ whew
  790.  endof
  791. 12 of \ decrement
  792. 4 -3 do
  793.  Rport Cx' @ I+ clipx Cy' @  ReadPixel 
  794. Loopix @ + 1 max rport swap setapen
  795.  Rport Cx' @ I+ clipx Cy' @  writePixel 
  796. loop
  797. rport CColor @ setapen
  798. endof
  799. 13 of \ increment
  800. 4 -3 do
  801.  Rport Cx' @ I+ clipx Cy' @  ReadPixel 
  802. Loopix @ - 31 Min rport swap setapen
  803.  Rport Cx' @ I+ clipx Cy' @  writePixel 
  804. loop
  805. rport CColor @ setapen
  806. endof
  807. 14 of  \ edible harmonie
  808.  
  809. cx' @ BackX @ >
  810. cx' @ BackX @ 2+ < and Backx @ 0= or
  811.  IF ( only writes contiguous )
  812. cx' @   BackX !
  813. Bdown'  Cy' @ -  B'fd @ *  B'fs @ + 8/ to temp \ CUrrent phase# to temp
  814. Temp Tharm !
  815. \ get the first corresponding y...
  816. BDown' Tharm @ B'Fs @ - B'Fd @ / - clipY TY !
  817. bdown'' lx !
  818. \ cr ." harm: " temp . ." :"
  819. rport 1 setapen
  820. begin
  821. ty @ i < If \ skip real low ones...
  822.   rport cx' @ lx @ Move
  823.   rport cx' @ ty @ 1+ Draw
  824.   Ty @ 1- lx !
  825. then
  826. \ next harmonic
  827. Temp Tharm +!
  828. \ convert tharm to Ty
  829. BDown' Tharm @ B'Fs @ - B'Fd @ / -  TY !
  830. \ ." (" Tharm @ . Ty @ . ." )"
  831. ty @ dup clipy ty ! bdown <
  832. until
  833. \ ." >"
  834. \ get the top..
  835. rport cx' @ lx @ move
  836. rport cx' @ bdown Draw
  837. \ ." <" cr
  838.  then  
  839. endof
  840. 15 of  \ eliminat low freqs
  841. 256 0 do
  842. I 170 20 n'text
  843.  128 0 do 
  844. rport Bleft j + bdown i+ readpixel
  845. 2 ccolor @ range  if \ wipe out if from 2 to ccolor
  846.   drop Rport 1 setapen Rport bleft j + Bdown i+ Writepixel
  847.   else drop 
  848.   then 
  849. loop
  850. loop 
  851. endof
  852. 16 of \ decrement ( not 0 )
  853. 4 -3 do
  854. 4 -3 do
  855.  Rport Cx' @ I+ clipx Cy' @ J + clipy  ReadPixel 
  856. dup 2 > if
  857. Loopix @ + 2 max rport swap setapen
  858.  Rport Cx' @ I+ clipx Cy' @ j + Clipy writePixel 
  859. else
  860. drop
  861. then
  862. loop
  863. loop
  864. rport CColor @ setapen
  865. endof
  866. 17 of \ increment ( not 0 )
  867. 4 -3 do
  868. 4 -3 do
  869.  Rport Cx' @ I+ clipx Cy' @ j + ClipY ReadPixel 
  870. dup 1 > if
  871. Loopix @ - 31 Min rport swap setapen
  872.  Rport Cx' @ I+ clipx Cy' @ J + Clipy writePixel 
  873. else drop
  874. then
  875. loop
  876. loop
  877. rport CColor @ setapen
  878. endof
  879.  
  880. 18 of \ set copy baseA...
  881. Curx'  CBAseXA !
  882. cury'  CbaseYA !
  883. endof
  884. 19 of \ set copy baseb...
  885. Curx'  CBAseXB !
  886. cury'  CbaseYB !
  887. endof
  888.  
  889. 20 of \ actually copy
  890. 3 -2 do
  891.  3 -2 do
  892. rport  rport cx' @ i+ clipx  cy' @ j + clipy readpixel setapen
  893. \ now stomp it
  894. Rport
  895.  cx' @ i+ clipx  cbaseXa @ - CbaseXB @ + CLipx
  896.  cy' @ j + clipy  cbaseYa @ - CbaseYB @ + CLipY WritePixel
  897. loop
  898. loop
  899. endof
  900.  
  901. 22 of \ Am modulate?
  902. Bdown'  Cy' @ -  B'fd @ *  B'fs @ +  locals| Temp | \ CUrrent phase# to temp
  903.  
  904. Bright bleft  do
  905. 14 temp  I bleft -  2048 */   Xqsin -8 scale 15 +  
  906. Rport swap setapen
  907. Rport I cy' @ WritePixel
  908. loop
  909. endof
  910.  
  911. 23 of \ copy whole lines..
  912. Bright Bleft DO
  913. Rport I Cbaseya @ ReadPixel Rport Swap Setapen
  914. Rport I Cy' @ WritePixel
  915. loop
  916. endof
  917. 24 of \ copy whole lines..
  918. BDown' Bdown DO
  919. Rport  CbaseXA @ I ReadPixel Rport Swap Setapen
  920. Rport  CX' @ I WritePixel
  921. loop
  922. endof
  923.  
  924. 25 of
  925. 1 flock !
  926. endof
  927. 26 of 2 flock !
  928. endof
  929. 27 of 4 flock !
  930. endof
  931. 28 of 8 flock !
  932. endof
  933. 29 of -10 HowLoud !
  934. endof
  935. 30 of -11 HowLoud !
  936. endof
  937. 31 of -12 HowLoud !
  938. endof
  939. endcase
  940. Else \ up button
  941. CdrMode @
  942. Case
  943. 2 of 
  944. cx' @ clipx vx !
  945. cy' @ clipy vy !
  946. endof
  947. endcase
  948. then
  949. then \ Cy' was too high? 
  950. eventpoll
  951.  until
  952. ;
  953.  
  954. {
  955. : DisplayIt ( x y Z -- ) \ hope that amt not> 128
  956. 4/ 1+ 31 min
  957. Rport swap  SetAPen
  958. rport rot rot WritePixel
  959. ;
  960. }
  961. \
  962. create @-8Scale -4 allot \ Code @-8scale
  963. hex
  964. 2057 w, \ a0 Get,
  965. 2010 w, \ A0 ()  d0 long Move,
  966. E080 W, \ D0 8 # Long Asr,
  967. 2E80 W, \ d0 Put,
  968. 361A w, 4EF6 W, 3018 W, \ next
  969. Decimal \ end-code
  970.  
  971.  
  972. \
  973. : ProcBPF
  974.  0 0 0 0  Locals| T#  S: f: W: |
  975.    B'Ze @ B'Zd @ - F' @@ + to F:
  976.    B'Zs @ F' @@ + to S:
  977. \ Do these little sub-loops, but ramp time before freq..
  978. 1 Wn'x !
  979. Bdown'' Dl'Y !
  980. N'P @ to W: \ Skip my nonsense ...
  981. B'Fe @ B'Fs @ DO
  982. I 3523 * -15 scale 170 20 n'text \ Standard freq display...  
  983. \  T'f @ I * 262143 and T'F ! \ scramble the phase somewhat..
  984.   t'f off
  985. \
  986.    Bleft Dl'X !
  987. \ set up wn'p =
  988. { skip more nonsense
  989.  262144 WN'X @ * i / dup N'P @ 2/ < If 1 wn'X +! then 
  990.  Dup to W:
  991.  250 25 N'text \ freq is below time
  992. }
  993. \ Now go over the sample block at this frequency, LPF them
  994. \
  995.    F: S: Do 
  996. \ freq = j..time = i
  997. \
  998. \ we gots to go slow here... cars is passing
  999. \ 
  1000.      T's Off
  1001.      T'c Off
  1002.      J I' !
  1003. \ Insert Assembler here ...
  1004.  
  1005.       W: I+ I do 
  1006.       I c@ B>  \ Get yer sample...
  1007. \
  1008.      T'f @-8scale 2dup
  1009.      XQSin  t's +! 
  1010.      XQCOS  t'c +!
  1011.  
  1012.       I' @ T'F +! \ move the wave forward
  1013.      loop
  1014.  
  1015. {
  1016.  T'F @  I' @  W: I+ I
  1017. \ d0  d1    a1    a0
  1018. >CODE
  1019. A0 Pop,  a1 Pop,  D1 Pop,  D0 Pop,
  1020. begin,
  1021. A0 )+ D2 Byte Move, \ D2 = M(I)
  1022. D2 Byte Ext, \ Extend somewhat
  1023. \ save this fer a second - probly oughta save all the registers!
  1024. d2 push,
  1025. \
  1026. \ --- incr freq,
  1027. d0  d1 long add, \ T'F = T'F + I'
  1028. a0 a1 long cmpa,  
  1029. gt until,
  1030.  
  1031. >Forth 
  1032. }
  1033. \
  1034.  
  1035.     Rport  T's @ W: W/ -6 scale dup W*
  1036.      T'c @ W: W/ -6 scale dup W*
  1037.      + sqrt 4/ 1+ 31 min SetAPen
  1038.     Rport   Dl'X @ Dl'Y @   WritePixel { DisplayIt }
  1039. \
  1040.      1 Dl'X +!
  1041.    B'Zd @ +loop 
  1042.  
  1043.    -1 Dl'Y +!
  1044. \
  1045. \ BPFDone?
  1046.    GetEvent
  1047.   fCloseWindow = IF Leave then
  1048. B'Fd @  +loop \ next frequency
  1049. 3 Mode !
  1050. ;
  1051.  
  1052.  
  1053.  
  1054. : BPFMode
  1055. CurrentWindow @ BPFMode$ -1 SetWindowTitles
  1056. getbpfFilename
  1057. \ draw the box
  1058. Rport 2 setApen
  1059. Rport BLeft  Bdown 1+  Bright 2-    Bdown  Bhei +   RectFill
  1060. \ draw the loopix box
  1061. ProcBpf
  1062. ;
  1063. Hex
  1064. Create ColtoByte \ somewhat stretched
  1065. \ 0     1     2     3     4     5     6     7    
  1066. 00 c, 00 c, 04 c, 08 c, 0c c, 10 c, 14 c, 18 c, 
  1067. \ 8     9    10    11    12    13    14    15    
  1068. 1c c, 20 c, 24 c, 28 c, 2c c, 30 c, 34 c, 38 c, 
  1069. \ 16    17    18    19   20    21    22    23    
  1070. 3c c, 40 c, 44 c, 48 c, 4c c, 50 c, 55 c, 59 c, 
  1071. \ 24   25    26    27    28    29    30    31    
  1072. 5e c, 63 c, 68 c, 6d c, 72 c, 76 c, 7c c, 7f c, 
  1073. Decimal
  1074. \
  1075. : SynthMode 
  1076. CurrentWindow @ SynthMode$ -1 SetWindowTitles
  1077. 0 0 0 0 0 0 0 Locals| Value Ovalue Sx Sy F-> IFreq JFaze |
  1078. Bleft to SX
  1079. F' @@ F'Sz @ Erase
  1080. F' @@ to F->
  1081. 0 Phase Bhei 4* erase \ Phases of each of the sins
  1082.  rport 2 SetDrMd
  1083.  Rport 15 setapen
  1084. \
  1085. Bright Bleft DO \ for each column (time slice of b'zd samples)
  1086. Rport i 1+ Bdown Move
  1087. Rport I 1+ Bdown' Draw
  1088. 0 Accum B'Zd @ 4* Erase \ zero out the special hi-res memory
  1089. \
  1090. B'fs @ to Ifreq
  1091.  Bdown  Bdown'' DO \ for each frequency ...
  1092.  Rport J I ReadPixel ColToByte + C@
  1093. ?dup If to Value
  1094. \  zero out the Accumulator Array...
  1095. \ sum up a sinwave (properly phased) at this amplitude
  1096. i Phase to JFaze
  1097. B'Zd @ 0 DO
  1098. Value  JFaze @ -8 scale
  1099. XQsin I Accum +!  
  1100. Ifreq JFaze +!
  1101. Loop
  1102. then
  1103. B'Fd @ Ifreq + to Ifreq
  1104. -1 +loop
  1105. \ now transfer the fourbyte values to the f-> array
  1106. \ ." --- Accum --- " cr
  1107. B'Zd @ 0 do
  1108. I Accum @ 
  1109.      \ so i made it -5! I'm clipping, aint I?
  1110. \ -7 scale ( number of frequencies ) -5 scale 
  1111. HowLoud @ scale
  1112. dup 127 > if drop 127 then
  1113.  dup -127 < if drop -127 then  F-> C! 
  1114. F-> 1+ to F->
  1115. loop
  1116. \ cr
  1117. Rport i 1+ Bdown Move
  1118. Rport I 1+ Bdown' Draw
  1119. eventpoll if Mode @ 2 = not if leave then  then  \ stop me before I kill again..
  1120. Loop
  1121. 3 Mode !
  1122.  rport 1 setdrmd
  1123. ;
  1124. \ This is the  Main switching loop, exiting in each case
  1125. \ by hitting closegadget..
  1126. \
  1127. \
  1128. : ProcDrw
  1129. Mode Off
  1130. Begin
  1131. \ split up into subgroups they will stay there till their mode changes?
  1132. mode @ case
  1133. 0 of TopMode endof
  1134. 1 of doodleMode endof
  1135. 2 of SynthMode endof
  1136. 3 of PlayMode endof
  1137. 4 of TopMode endof
  1138. 6 of writemode endof
  1139. 7 of BPFMode   endof
  1140. 8 of GetDrwParms endof
  1141. 9 of InputMode endof
  1142. 10 of outputmode endof
  1143. \ 5 = quit
  1144. endcase
  1145.  
  1146. Mode @ 5 =
  1147. until
  1148. \ drop  \ we'll figger out why later...(figgered out??)
  1149. ;
  1150. \ 
  1151. : Drw
  1152. Decimal 
  1153. BigBegin
  1154.  if
  1155. PutUpScreen
  1156. ProcDrw 
  1157. ShutUpScreen \ and free core...
  1158. else
  1159. ." I couldn't get core... " cr
  1160. then
  1161. ?turnkey if bye else Depth IF ." funny depth:" depth . then   abort then
  1162. ; 
  1163. \ 
  1164. ." Drw is in " cr
  1165.