\ LeCroy waveform capture Andrew J. Korsak, Ph.D. 02jun2000 \ ve3fzk@arrl.net \ Based on: \ WINDEMO.F March 24th, 1999 - 21:37 only forth also definitions fload LecroySetup \ integrated captured parameter window ajk 06jun2000 DLL: gpib-32 0 value gpib-board-index 4 value LeCroy-GPIB-address 0 value LeCroy-secondary-address 10 value gpib-timeout-seconds 1 value send-end-message 0 value enable-EOS-detection-mode : my_ibdev ( -- ud0_value ) enable-EOS-detection-mode send-end-message gpib-timeout-seconds LeCroy-secondary-address LeCroy-GPIB-address gpib-board-index call ibdev ; 0 value ud0 : init-gpib my_ibdev TO ud0 ; \ 220000 constant buflen 100000 constant buflen create plotbuf buflen allot : cmd $7C word count swap rel>abs ud0 call ibwrt drop ; : ibread ( count -- ) plotbuf rel>abs ud0 call ibrd drop ; : release-scope ( -- ) ud0 call ibclr drop ud0 call ibloc drop ; 1280 value screen-mwidth 1024 value screen-mheight 400 to screen-width 300 to screen-height \ --------------------------------------------------------------- \ Define the BIT-WINDOW global drawing functions \ --------------------------------------------------------------- Windc LeCroy-dc 2 value bit-originx 2 value bit-originy 0 value LINE-VALUE 0 value walking? 0 value line-count 0 value save-count 0 value do-printing? -1 value prev-x -1 value prev-y : moveto ( x y -- ) 0max screen-height 4 - min swap 0max screen-width 4 - min swap bit-originy + swap bit-originx + swap over prev-x = over prev-y = and IF 2drop ELSE 2dup to prev-y to prev-x 2dup PrinterMoveTo: ThePrinter MoveTo: LeCroy-dc THEN ; : lineto ( x y -- ) 0max screen-height 4 - min swap 0max screen-width 4 - min swap bit-originy + swap bit-originx + swap over prev-x = over prev-y = and IF 2drop ELSE 2dup to prev-y to prev-x 2dup PrinterLineTo: ThePrinter LineTo: LeCroy-dc then 1 +to line-count ; : line ( x1 y1 x2 y2 -- ) 2swap moveto lineto ; : line-color ( color_object -- ) ?ColorCheck dup to line-value dup case black of white endof white of black endof yellow of blue endof dup endcase PrinterLineColor: ThePrinter LineColor: LeCroy-dc ; \ --------------------------------------------------------------- \ Define the BIT-WINDOW window class \ --------------------------------------------------------------- :Class bit-window abs GetHandle: dc call FillRect ?win-error EraseRect: LeCroyRect On_Paint: super WHITE LineColor: dc \ white color 0 0 MoveTo: dc \ horiz StartSize: self drop width max 0 LineTo: dc \ line 0 0 MoveTo: dc \ vertical StartSize: LeCroy-Tool-Bar nip 0 swap LineTo: dc \ line StartSize: LeCroy-Tool-Bar swap 1+ swap MoveTo: dc \ vertical StartSize: LeCroy-Tool-Bar drop 1+ 0 LineTo: dc \ line BLACK LineColor: dc 0 StartSize: LeCroy-Tool-Bar nip dup>r MoveTo: dc StartSize: self drop width max r> LineTo: dc StartSize: LeCroy-Tool-Bar over 0 MoveTo: dc LineTo: dc ;M \ the l parameter has already been removed by WINDOW.F, and put \ into Height and Width :M On_Size: ( h m w -- ) \ handle resize message Width StartSize: LeCroy-V-Buttons >r - 2 + r> Height StartSize: LeCroy-LR-Buttons bitorigy 2 - 0max + swap 4 - >r dup>r - over - r> 4 > \ if there are buttons in the bar IF 2 - \ then leave two more pixels of room \ else we'll already have two pixels of room ELSE r>drop StartSize: LeCroy-V-Buttons drop 4 - 0max >r THEN r> swap StartSize: LeCroy-Tool-Bar nip 1+ >r 2swap r@ + 2swap r> - Move: button-fill-window bitorigx bitorigy StartSize: LeCroy-Tool-Bar nip + 1+ Width StartSize: LeCroy-V-Buttons drop - 2 - dup to screen-width Height 4 - StartSize: LeCroy-Tool-Bar nip - 1- dup to screen-height Move: vga-bit-window Width StartSize: LeCroy-V-Buttons drop - bitorigy 2 - 0max StartSize: LeCroy-Tool-Bar nip + 1+ StartSize: LeCroy-V-Buttons Move: LeCroy-V-Buttons Width StartSize: LeCroy-LR-Buttons drop - Height StartSize: LeCroy-LR-Buttons nip - bitorigy 2 - 0max - StartSize: LeCroy-LR-Buttons Move: LeCroy-LR-Buttons 0 0 StartSize: LeCroy-Tool-Bar Move: LeCroy-Tool-Bar ;M :M SetVButtonBar: { buttonbar -- } buttonbar LeCroy-V-Buttons <> IF Close: LeCroy-V-Buttons buttonbar to LeCroy-V-Buttons self Start: LeCroy-V-Buttons On_Size: self then ;M :M SetLRButtonBar: { buttonbar -- } buttonbar LeCroy-LR-Buttons <> IF Close: LeCroy-LR-Buttons buttonbar to LeCroy-LR-Buttons self Start: LeCroy-LR-Buttons On_Size: self then ;M \ Mouse support connections from the applications window to the bitmapped \ window that will actually receive the mouse clicks :M SetClickFunc: ( cfa -- ) SetClickFunc: vga-bit-window ;M :M SetUnClickFunc: ( cfa -- ) SetUnClickFunc: vga-bit-window ;M :M SetDblClickFunc: ( cfa -- ) SetDblClickFunc: vga-bit-window ;M :M SetTrackFunc: ( cfa -- ) SetTrackFunc: vga-bit-window ;M \ All SC_xxxx command types always have the high nibble set to 0xF :M WM_SYSCOMMAND ( hwnd msg wparam lparam -- res ) over 0xF000 and 0xF000 <> IF over LOWORD DoMenu: CurrentMenu 0 ELSE DefWindowProc: [ self ] THEN ;M ;Object : uninit-LeCroy ( -- ) DestroyWindow: LeCroyW ; unload-chain chain-add-before uninit-LeCroy \ --------------------------------------------------------------- \ LeCroy about dialog, copied from the Forth About Dialog \ --------------------------------------------------------------- create about-LeCroy-msg z," LeCroyCapture, Last Updated June 2000\n" +z," Version 1.2\n\n" +z," Andrew Korsak" -null, here 0 c, align about-LeCroy-msg - constant about-LeCroy-len :Object AboutWinLeCroy r + r> message-origin MessageText: msg-window Start: msg-window ELSE 2drop THEN ; : LeCroy-message-off ( -- ) message-off StartPos: LeCroyW StartPos: msg-window rot - 0max >r swap - 0max r> message-origin ; \ copy VGA-DC bitmap, f1=true=inverted : copy-LeCroy-bitmap { flag \ hbm hdcMem -- } GetHandle: LeCroyW call OpenClipboard 0= IF s" Can't Open Clipboard\n\n...press a key to continue" "LeCroy-message key drop LeCroy-message-off EXIT THEN flag SCREEN-HEIGHT SCREEN-WIDTH GetHandle: LeCroy-dc call CreateCompatibleBitmap to hbm GetHandle: LeCroy-dc call CreateCompatibleDC to hdcMem hbm hdcMem call SelectObject drop r> IF NOTSRCCOPY ELSE SRCCOPY THEN 0 0 \ y,x origin GetHandle: LeCroy-dc \ from the screen SCREEN-HEIGHT \ source height SCREEN-WIDTH \ source width 0 0 hdcMem \ to new bitmap call BitBlt ?win-error \ invert the bitmap call EmptyClipboard ?win-error \ clear out the clipboard hbm CF_BITMAP call SetClipboardData ?win-error call CloseClipboard ?win-error hdcMem call DeleteDC ?win-error \ We don't delete the bitmap because it is now owned by the clipboard !! \ hbm call DeleteObject ?win-error ; : paste-LeCroy-bitmap { flag \ hbm hdcMem -- } GetHandle: LeCroyW call OpenClipboard 0= IF s" Can't Open Clipboard\n\n...press a key to continue" "LeCroy-message 2000 ms LeCroy-message-off EXIT then SCREEN-WIDTH SCREEN-HEIGHT CreateCompatibleBitMap: LeCroy-dc to hbm GetHandle: LeCroy-dc call CreateCompatibleDC to hdcMem CF_BITMAP call GetClipboardData dup to hbm ?win-error hbm hdcMem call SelectObject drop flag IF NOTSRCCOPY ELSE SRCCOPY THEN 0 0 \ y,x origin hdcMem \ from memory dc SCREEN-HEIGHT \ source height SCREEN-WIDTH \ source width 0 0 \ y,x dest GetHandle: LeCroy-dc \ to screen call BitBlt ?win-error \ invert the bitmap call CloseClipboard ?win-error hdcMem call DeleteDC ?win-error \ hbm call DeleteObject ?win-error ; FileOpenDialog ViewBitmap "Open Bitmap File" "Bitmap Files (*.BMP)|*.BMP|*.DIB|All Files (*.*)|*.*|" FileSaveDialog SaveBitmap "Save Bitmap File" "Bitmap Files (*.BMP)|*.BMP|*.DIB|All Files (*.*)|*.*|" \ --------------------------------------------------------------- \ Open image file support \ --------------------------------------------------------------- : open-LeCroy-bitmap { \ open$ hbm hdcMem -- } max-path LocalAlloc: open$ GetHandle: LeCroyW Start: ViewBitmap dup c@ \ -- a1 n1 IF count open$ place LR_LOADFROMFILE LR_CREATEDIBSECTION or NULL NULL IMAGE_BITMAP open$ dup +NULL 1+ rel>abs NULL Call LoadImage to hbm GetHandle: LeCroy-dc Call CreateCompatibleDC to hdcMem hbm hdcMem Call SelectObject drop SRCCOPY \ 0 0 \ y,x origin hdcMem \ from memory dc SCREEN-HEIGHT \ height of dest rect SCREEN-WIDTH \ width of dest rect 0 0 \ y,x dest GetHandle: LeCroy-dc \ to screen Call BitBlt ?win-error \ hdcMem Call DeleteDC ?win-error ELSE DROP THEN ; \ --------------------------------------------------------------- \ Save File support \ --------------------------------------------------------------- 4 constant sizeof(RGBQUAD) 14 constant sizeof(BitmapFileHeader) 40 constant sizeof(BitmapInfoHeader) 0 constant biSize 4 constant biWidth 8 constant biHeight 12 constant biPlanes 14 constant biBitCount 16 constant biCompression 20 constant biSizeImage 24 constant biXPelsPerMeter 28 constant biYPelsPerMeter 32 constant biClrUsed 36 constant biClrImportant : show-BITMAPINFOHEADER { pbmih \ bmih$ -- } max-path localalloc: bmih$ s" BITMAPINFOHEADER" bmih$ place s" \nbiSize : " bmih$ +place pbmih biSize + @ 0 <# #s #> bmih$ +place s" \nbiWidth : " bmih$ +place pbmih biWidth + @ 0 <# #s #> bmih$ +place s" \nbiHeight : " bmih$ +place pbmih biHeight + @ 0 <# #s #> bmih$ +place s" \nbiPlanes : " bmih$ +place pbmih biPlanes + w@ 0 <# #s #> bmih$ +place s" \nbiBitCount : " bmih$ +place pbmih biBitcount + w@ 0 <# #s #> bmih$ +place s" \nbiCompression : " bmih$ +place pbmih biCompression + @ 0 <# #s #> bmih$ +place s" \nbiSizeImage : " bmih$ +place pbmih biSizeImage + @ 0 <# #s #> bmih$ +place s" \nbiXPelsPerMeter : " bmih$ +place pbmih biXPelsPerMeter + @ 0 <# #s #> bmih$ +place s" \nbiYPelsPerMeter : " bmih$ +place pbmih biYPelsPerMeter + @ 0 <# #s #> bmih$ +place s" \nbiClrUsed : " bmih$ +place pbmih biClrUsed + @ 0 <# #s #> bmih$ +place s" \nbiClrImportant :" bmih$ +place pbmih biClrImportant + @ 0 <# #s #> bmih$ +place bmih$ count "message key drop message-off ; : save-LeCroy-bitmap { nBits \ pbmi lpBits hbm hdcMem hfile nrgbquad BitmapFileHeader save$ -- } 14 LocalAlloc: BitmapFileHeader max-path LocalAlloc: save$ s" Save Bitmap File: " save$ place nBits (.) save$ +place s" Bit" save$ +place save$ count SetTitle: SaveBitmap GetHandle: LeCroyW Start: SaveBitmap dup c@ IF count save$ place sizeof(BitmapInfoHeader) sizeof(RGBQUAD) 256 * + malloc to pbmi pbmi sizeof(BitmapInfoHeader) sizeof(RGBQUAD) 256 * + erase \ (1) DON'T DELETE THIS LINE \ sizeof(BitmapInfoHeader) pbmi biSize + ! SCREEN-WIDTH pbmi biWidth + ! SCREEN-HEIGHT pbmi biHeight + ! 1 pbmi biPlanes + w! nBits pbmi biBitCount + w! nBits CASE 1 OF BI_RGB 2 to nrgbquad ENDOF 4 OF BI_RLE4 16 to nrgbquad ENDOF \ Could also be BI_RGB for 8 OF BI_RLE8 256 to nrgbquad ENDOF \ uncompressed format 16 OF BI_RGB 0 to nrgbquad ENDOF 24 OF BI_RGB 0 to nrgbquad ENDOF 32 OF BI_RGB 0 to nrgbquad ENDOF ENDCASE pbmi biCompression + ! \ 0 pbmi biSizeImage + ! NOT NEEDED (1) \ 0 pbmi biXPelsPerMeter + ! SINCE \ 0 pbmi biYPelsPerMeter + ! pbmi IS ERASED \ 0 pbmi biClrUsed + ! ABOVE \ 0 pbmi biClrImportant + ! SCREEN-HEIGHT SCREEN-WIDTH GetHandle: LeCroy-dc Call CreateCompatibleBitmap to hbm GetHandle: LeCroy-dc Call CreateCompatibleDC to hdcMem hbm hdcMem Call SelectObject drop SRCCOPY \ 0 0 \ y,x origin GetHandle: LeCroy-dc \ from screen dc SCREEN-HEIGHT \ height of dest rect SCREEN-WIDTH \ width of dest rect 0 0 \ y,x dest hdcMem \ to memory dc Call BitBlt ?win-error \ DIB_RGB_COLORS pbmi rel>abs NULL SCREEN-HEIGHT 0 hbm hdcMem Call GetDIBits 0= abort" 1st GetDIBits" pbmi show-bitmapinfoheader pbmi biSizeImage + @ malloc rel>abs to lpBits lpBits abs>rel pbmi biSizeImage + @ erase DIB_RGB_COLORS pbmi rel>abs lpBits SCREEN-HEIGHT 0 hbm hdcMem Call GetDIBits 0= abort" 2nd GetDIBits" pbmi show-bitmapinfoheader save$ count GENERIC_READ GENERIC_WRITE or create-file abort" CreateFile" to hfile 0x4d42 BitmapFileHeader w! \ hdr.bfType sizeof(BitmapFileHeader) sizeof(BitmapInfoHeader) + nrgbquad sizeof(RGBQUAD) * + pbmi biSizeImage + @ + BitmapFileHeader 2 + ! \ hdr.bfSize 0 BitmapFileHeader 6 + w! \ hdr.bfReserved1 0 BitmapFileHeader 8 + w! \ hdr.bfReserved2 sizeof(BitmapFileHeader) sizeof(BitmapInfoHeader) + nrgbquad sizeof(RGBQUAD) * + BitmapFileHeader 10 + ! \ hdr.bfOffBits BitmapFileHeader sizeof(BitmapFileHeader) hfile write-file drop pbmi sizeof(BitmapInfoHeader) nrgbquad sizeof(RGBQUAD) * + hfile write-file drop lpBits abs>rel pbmi biSizeImage + @ hfile write-file drop hfile close-file drop hdcMem call DeleteDC ?win-error hbm call DeleteObject ?win-error lpBits abs>rel release pbmi release ELSE drop THEN ; ' save-LeCroy-bitmap is save-bitmap only forth also definitions \ --------------------------------------------------------------- \ Actual application section for LeCroyCapture \ --------------------------------------------------------------- 320 value center-x 175 value center-y 240 value scale-y 1 value delay-ms 16 value cdiam 0 value ccolor create colors DKGRAY , RED , LTRED , GREEN , LTGREEN , BLUE , LTBLUE , YELLOW , LTYELLOW , MAGENTA , LTMAGENTA , CYAN , LTCYAN , GRAY , WHITE , LTGRAY , : >color ( n1 -- color_object ) 15 and colors +cells @ ; 20000 value numpts 369 value startloc \ default values : drawplot ( -- ) \ white line-color 1 +TO ccolor ccolor >color line-color 1 center-y moveto numpts 0 DO screen-width I numpts */ \ hor_pos screen-width 4 - min 4 max \ x ccordinate screen-height 2/ plotbuf startloc + I 2* + c@ ( -- x vertsize/2 value ) dup $80 and ( -- x vertsize/2 value sign ) if $7F and $80 - then \ convert ADC sign convention $7F */ screen-height 2/ + screen-height swap - \ counting pixels up from the bottom 4 max screen-height 4 - min \ y coordinate lineto LOOP ; : new-waveplot ( -- ) \ draw a new waveplot, screen-width 2 / 1- TO center-x screen-height 2 / 1- TO center-y \ calibrate screen center center-x center-x center-y */ TO scale-y \ calibrate aspect ratio white line-color \ default color=white \ show-border \ show-circle ; \ display the circle drawplot ; \ ajk 01jun2000 : n@ ( adr -- <"little-end" value at adr> ) dup c@ $100 * swap 1+ c@ + ; : L@ ( adr -- <"little-end" value at adr> ) dup n@ $10000 * swap 2 + n@ + ; : wave-points ( -- n ) plotbuf 80 + L@ ; : wave-adr ( -- n ) plotbuf 61 + n@ ; : get-waveform ( -- ) ud0 call ibclr drop s" WAIT;C3:WF?" swap rel>abs ud0 call ibwrt drop startloc numpts 2* + 2 + ibread ; : trigger-scope ( -- ) s" WAIT;*CLS;ARM" swap rel>abs ud0 call ibwrt drop ; : setup-LeCroy ( -- ) s" WAIT;WFSU SP,0,FP,0,SN,1,NP,20000" swap rel>abs ud0 call ibwrt drop ; 100 value cmndlen 200 value paramlen create cmndbuf cmndlen allot create parambuf paramlen allot 0 value namelen 0 value cmndlen : get&display-parameters ( -- ) 4 0 DO s" PAVA? " ( cmndadr cnt ) to cmndlen cmndbuf cmndlen BL fill ( cmndadr ) cmndbuf cmndlen cmove ( -- ) I GetList: LeCroySetup&ParameterDisplay ( param_name_adr, cnt ) to namelen ( param_name_adr ) cmndbuf cmndlen + namelen cmove namelen cmndlen + ( total_cmnd_length ) cmndbuf rel>abs ud0 call ibwrt drop parambuf paramlen BL fill paramlen parambuf rel>abs ud0 call ibrd drop parambuf paramlen I SetEditBox: LeCroySetup&ParameterDisplay \ parambuf paramlen type .s \ WINPAUSE LOOP WINPAUSE ; : get&show-waveform trigger-scope ( 10 ms) get&display-parameters get-waveform release-scope new-waveplot WINPAUSE ; : run-Lecroy begin get&show-waveform key? do-printing? IF line-count save-count >= OR THEN Refresh: LeCroyW WINPAUSE delay-ms 1+ 100 min to delay-ms delay-ms ms until release-scope ; : erase-LeCroy ( -- ) 0 0 screen-width screen-height WHITE PrinterFillArea: ThePrinter 0 0 screen-width screen-height BLACK FillArea: LeCroy-dc 0 to line-count ; \ --------------------------------------------------------------- \ Actual application section for SINGLE WAVEFORM \ --------------------------------------------------------------- \ replaced by: get&show-waveform \ --------------------------------------------------------------- \ Printing support \ --------------------------------------------------------------- : print-LeCroy ( -- ) TRUE to do-printing? single-page start-scaled IF erase-LeCroy S" Printing LeCroyCapture..." "LeCroy-message walking? IF get&show-waveform ELSE run-LeCroy THEN print-scaled LeCroy-message-off THEN FALSE to do-printing? ; : print-LeCroy-bmp { nBits \ pbmi lpBits hbm hdcMem -- } Open: ThePrinter GetHandle: ThePrinter 0= ?EXIT Start: ThePrinter sizeof(BitmapInfoHeader) sizeof(RGBQUAD) 256 * + malloc to pbmi pbmi sizeof(BitmapInfoHeader) sizeof(RGBQUAD) 256 * + erase \ (1) DON'T DELETE THIS LINE \ sizeof(BitmapInfoHeader) pbmi biSize + ! SCREEN-WIDTH pbmi biWidth + ! SCREEN-HEIGHT pbmi biHeight + ! 1 pbmi biPlanes + w! nBits pbmi biBitCount + w! BI_RGB pbmi biCompression + ! \ 0 pbmi biSizeImage + ! NOT NEEDED (1) \ 0 pbmi biXPelsPerMeter + ! SINCE \ 0 pbmi biYPelsPerMeter + ! pbmi IS ERASED \ 0 pbmi biClrUsed + ! ABOVE \ 0 pbmi biClrImportant + ! SCREEN-HEIGHT SCREEN-WIDTH GetHandle: LeCroy-dc Call CreateCompatibleBitmap to hbm GetHandle: LeCroy-dc Call CreateCompatibleDC to hdcMem hbm hdcMem Call SelectObject drop SRCCOPY \ 0 0 \ y,x origin GetHandle: LeCroy-dc \ from screen dc SCREEN-HEIGHT \ height of dest rect SCREEN-WIDTH \ width of dest rect 0 0 \ y,x dest hdcMem \ to memory dc Call BitBlt ?win-error \ DIB_RGB_COLORS pbmi rel>abs NULL SCREEN-HEIGHT 0 hbm hdcMem Call GetDIBits 0= abort" 1st GetDIBits" pbmi show-bitmapinfoheader pbmi biSizeImage + @ malloc rel>abs to lpBits lpBits abs>rel pbmi biSizeImage + @ erase DIB_RGB_COLORS pbmi rel>abs lpBits SCREEN-HEIGHT 0 hbm hdcMem Call GetDIBits 0= abort" 2nd GetDIBits" pbmi show-bitmapinfoheader SRCCOPY DIB_RGB_COLORS pbmi rel>abs lpBits SCREEN-HEIGHT SCREEN-WIDTH 0 0 Height: ThePrinter Width: ThePrinter 0 0 GetHandle: ThePrinter Call StretchDIBits GDI_ERROR = ABORT" StretchDIBits" End: ThePrinter Close: ThePrinter hdcMem call DeleteDC ?win-error hbm call DeleteObject ?win-error lpBits abs>rel release pbmi release ; \ --------------------------------------------------------------- \ Top Level program starts here \ --------------------------------------------------------------- : WINLeCroy ( -- ) Start: LeCroyW StartPos: LeCroyW 50 + swap 50 + swap message-origin init-gpib setup-LeCroy erase-LeCroy begin Refresh: LeCroyW key \ handle keyboard interpretation case 'O' +k_control of open-LeCroy-bitmap endof '1' of 1 save-bitmap endof '2' of 4 save-bitmap endof '3' of 8 save-bitmap endof '4' of 16 save-bitmap endof '5' of 24 save-bitmap endof '6' of 32 save-bitmap endof 'S' +k_control of 16 save-bitmap endof 'V' +k_control of paste-LeCroy-bitmap endof 'P' +k_control of print-LeCroy endof 'Q' +k_control of 16 print-LeCroy-bmp endof k_F1 of help-on-help endof k_F1 +k_control of about-LeCroy endof k_cr of run-LeCroy endof k_cr +k_control of get&show-waveform endof k_esc of erase-LeCroy endof k_esc +k_control of endof 'P' +k_control +k_shift of GetHandle: LeCroyW Setup: ThePrinter endof 'C' +k_control of false copy-LeCroy-bitmap endof 'C' +k_control +k_shift of true copy-LeCroy-bitmap endof 'X' +k_control of false copy-LeCroy-bitmap k_esc pushkey endof endcase again ; : wc Start: LeCroySetup&ParameterDisplay winlecroy ; ' wc turnkey LeCroyCapture \ build an application on disk \ 5 pause-seconds