home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 402.lha / IconTools / source / FloatIcon.f < prev    next >
Text File  |  1990-07-27  |  11KB  |  516 lines
  1. \ FloatIcon.f     1.03
  2. \ Program to release several icons simultaneously so that WorkBench will
  3. \ handle their placement in a drawer window.
  4. \ Written in JForth Professional 2.0
  5. \
  6. \ (c) Copyright 1989, 1990 by Richard Mazzarisi.
  7. \  All rights reserved.
  8. \
  9. \ address:
  10. \    891 Post St. #207
  11. \    San Francisco, CA
  12. \    94109
  13. \
  14. \ email:
  15. \    rich@californium.cchem.berkeley.edu
  16. \    rmazz@hydrogen.cchem.berkeley.edu
  17. \
  18. \
  19. \ 5/20/90
  20. \
  21. \ v. 1.00 10/9/89
  22. \ v. 1.01 2/3/90   fixed the path name for drawers, WB gives you the name
  23. \            with a '/' at the end which must be removed whereas
  24. \            Jazzbench does not
  25. \ v. 1.02 3/22/90  fixed bug in 'remove.final.slash' was 2DROP changed to DROP
  26. \      3/23/90  fixed problem similar to '/' with ':' on device icons
  27. \ v. 1.03 5/20/90  fixed the ability to find the font size and use this info
  28. \            in opening the window
  29.  
  30. \ Instructions:
  31. \ 1 - Click on the icon for this program.
  32. \ 2 - Shift click on all icons to be floated.
  33. \
  34. \ (NOTE: The author assumes no responsibility for any damages
  35. \ resulting from the use of this program.)
  36.  
  37.  
  38. INCLUDE? CLONE CL:TOPFILE
  39. INCLUDE? LIBRARIES_DOS_H JI:LIBRARIES/DOS.J
  40. INCLUDE? LIBRARIES_DOSEXTENS_H JI:LIBRARIES/DOSEXTENS.J
  41. INCLUDE? EXEC_MEMORY_H JI:EXEC/MEMORY.J
  42. INCLUDE? TASK-AMIGA_GRAPH JU:AMIGA_GRAPH
  43. INCLUDE? TASK-AMIGA_EVENTS JU:AMIGA_EVENTS
  44. INCLUDE? TASK-CONSOLESUPPORT JU:CONSOLESUPPORT
  45. INCLUDE? TASK-ANSISUPPORT JU:ANSISUPPORT
  46. INCLUDE? TASK-DOS-SUPPORT JU:DOS-SUPPORT
  47. INCLUDE? TASK-SET-ICON JU:SET-ICON
  48. INCLUDE? TASK-LOCALS JU:LOCALS
  49.  
  50.  
  51. .NEED clone-it
  52.  
  53. \ *** clone controller ***
  54.  
  55. VARIABLE clone-it
  56. clone-it OFF
  57.  
  58. .THEN
  59.  
  60.  
  61. ANEW task-floaticon
  62.  
  63. DECIMAL
  64.  
  65.  
  66. \ *** console stuff ***
  67.  
  68. \ variables to hold the request and reply ports
  69. VARIABLE wreq
  70. VARIABLE rreq
  71. VARIABLE wreply
  72. VARIABLE rreply
  73.  
  74.  
  75. : con.cr    ( -- )
  76.     wreq @ $ 0A ConPutChar()
  77. ;
  78.  
  79.  
  80. : con.write    ( straddr -- )
  81.     wreq @    SWAP COUNT ConWrite()
  82. ;
  83.  
  84.  
  85. : con.write.c3 ( straddr -- )
  86. \ write string in color 3
  87.     1 33 2 CRender3  wreq @  >ANSIDEVICE
  88.     con.write
  89.     0 1 CRender3  wreq @  >ANSIDEVICE
  90. ;
  91.  
  92.  
  93. : con.write.itl ( straddr -- )
  94. \ write string in bold italics
  95.     3 1 2 CRender3    wreq @    >ANSIDEVICE
  96.     con.write
  97.     0 1 CRender3  wreq @  >ANSIDEVICE
  98. ;
  99.  
  100.  
  101. : clear.line    ( -- )
  102. \ clear current line
  103.     0 CDeleteLine wreq @ >ANSIDEVICE
  104. ;
  105.  
  106.  
  107. : cursor.off    ( -- )
  108. \ get rid of cursor
  109.     0 CCursOff wreq @ >ANSIDEVICE
  110. ;
  111.  
  112.  
  113. \ *** main window stuff ***
  114.  
  115. CREATE scr-buff Sizeof() Screen ALLOT
  116. NewWindow ft-window
  117.  
  118. : getWBscreendata    ( -- )
  119.     scr-buff Sizeof() Screen WBENCHSCREEN NULL
  120.     CALL>ABS INTUITION_LIB GetScreenData  NULL = IF
  121.         ABORT" Could not get Workbench screen data."
  122.     THEN
  123. ;
  124.  
  125.  
  126. : set.vert-params ( topedge #lines -- topedge' height )
  127. \ calc window height, adjust topedge if necessary
  128.     scr-buff ..@ sc_Font            \ get font
  129.     >REL ..@ ta_YSize            \ font height
  130.     \ estimate height from #lines, title bar height and lower border
  131.     *  scr-buff ..@ sc_BarHeight +    12 +
  132.     \ check if too high
  133.     2DUP +    scr-buff ..@ sc_Height > IF
  134.         \ try adjusting topedge
  135.         SWAP DROP   \ lose old topedge
  136.         scr-buff ..@ sc_Height OVER -  DUP 0< IF
  137.             \ not going to work; set to 0 & screen height
  138.             2DROP
  139.             0  scr-buff ..@ sc_Height
  140.         ELSE
  141.             SWAP
  142.         THEN
  143.     THEN
  144. ;
  145.  
  146.  
  147. : set.horiz-params ( leftedge #chars -- leftedge' width )
  148. \ calc window width, adjust leftedge if necessary
  149.     scr-buff .. sc_RastPort ..@ rp_TxWidth        \ get font width
  150.     \ estimate width from #chars, and borders
  151.     *  24 +
  152.     \ check if too wide
  153.     2DUP +    scr-buff ..@ sc_Width > IF
  154.         \ try adjusting leftedge
  155.         SWAP DROP   \ lose old leftedge
  156.         scr-buff ..@ sc_Width OVER -  DUP 0< IF
  157.             \ not going to work; set to 0 & screen width
  158.             2DROP
  159.             0  scr-buff ..@ sc_Width
  160.         ELSE
  161.             SWAP
  162.         THEN
  163.     THEN
  164. ;
  165.  
  166.  
  167. : open.ft-window      ( -- window/null )
  168.     getWBscreendata
  169.     ft-window NEWWINDOW.SETUP
  170.     20 15 set.vert-params
  171.     ft-window ..! nw_Height
  172.     ft-window ..! nw_TopEdge
  173.     20 51 set.horiz-params
  174.     ft-window ..! nw_Width
  175.     ft-window ..! nw_LeftEdge
  176.     0" FloatIcon  1.03" >ABS ft-window ..! nw_Title
  177.     CLOSEWINDOW ft-window ..! nw_IDCMPFlags
  178.     WINDOWCLOSE WINDOWDRAG | WINDOWDEPTH | WINDOWSIZING |
  179.         ft-window ..! nw_Flags
  180.     ft-window GR.OPENCURW
  181. ;
  182.  
  183.  
  184. : wait.close    ( -- )
  185.     BEGIN
  186.         GR-CURWINDOW @ EV.WAIT
  187.         GR-CURWINDOW @ EV.GETCLASS
  188.         CLOSEWINDOW =
  189.     UNTIL
  190. ;
  191.  
  192.  
  193. \ *** string stuff ***
  194.  
  195. : init.name    ( -- )
  196.     0 PAD !
  197. ;
  198.  
  199.  
  200. : build.name    ( addr count -- )
  201. \ must init to null with init.name before using this word for the first
  202. \ time in building a new path name
  203.     PAD @ 0= IF
  204.         PAD >$
  205.     ELSE
  206.         PAD $APPEND
  207.     THEN
  208. ;
  209.  
  210.  
  211. \ *** resource management ***
  212.  
  213. : close.ft-things    ( -- )
  214.     wait.close
  215.     wreq @ 0= NOT IF
  216.         wreply @ wreq @ rreply @ rreq @ ReleaseConsole()
  217.         wreq OFF
  218.     THEN
  219.     GR.CLOSECURW
  220.     GR.TERM
  221. ;
  222.  
  223.  
  224. : prt.close-msg     ( -- )
  225.     con.cr
  226.     " Click CloseBox to exit." con.write
  227. ;
  228.  
  229.  
  230. : ft.abort    ( -- )
  231.     con.cr prt.close-msg
  232.     close.ft-things
  233.     ABORT
  234. ;
  235.  
  236.  
  237. : open.ft-things    ( -- t/f )
  238. \ The error messages are for debugging under the interpreter; they won't
  239. \ be able to be seen under the workbench.
  240.     GR.INIT
  241.     wreq OFF
  242.     GR-CURWINDOW OFF
  243.     \ open window
  244.     open.ft-window    NULL = IF
  245.         ABORT" Could not open a window!"
  246.     THEN
  247.     \ make it a console
  248.     gr-curwindow @ GetConsole() NULL = IF
  249.         close.ft-things
  250.         ABORT" Could not create a console device!"
  251.     ELSE
  252.         rreq ! rreply !  wreq ! wreply !
  253.         cursor.off
  254.     THEN
  255. ;
  256.  
  257.  
  258. \ *** modified words from JU:SET-ICON ***
  259. \ these must not call ?ABORT" but must use ft.abort to clean up
  260. \ probably don't need most of the error messages but leave them for debugging
  261.  
  262. : ft.icon-open?  ( -- , just checks for 0 )
  263.     theIcon @ 0= IF
  264.         " ERROR: No Icon selected ... use GET-ICON" con.write.itl con.cr
  265.         ft.abort
  266.     THEN
  267. ;
  268.  
  269.  
  270. : ft.abort-icon    ( -- , just clear it out )
  271.     ft.icon-open? theIcon @  FreeDiskObject()
  272.     theIcon OFF  thestrings @ FREEBLOCK
  273. ;
  274.  
  275.  
  276. : $ft.get-icon      ( adr-forth-string -- )
  277.     \ NOTE: do NOT include the '.info' suffix in the pathname
  278.     theIcon @ IF
  279.         " ERROR: 'theIcon' currently holds another icon."
  280.         con.write.itl con.cr
  281.         ft.abort
  282.     THEN
  283.     COUNT >DOS DOS0   GetDiskObject() -DUP 0= IF
  284.         " ERROR: Can't Get the ICON file!" con.write.itl con.cr
  285.         ft.abort
  286.     THEN
  287.     theIcon !  MEMF_PUBLIC 1024 ALLOCBLOCK -DUP 0= IF
  288.         " ERROR: No memory for ICON strings!" con.write.itl con.cr
  289.         ft.abort
  290.     ELSE
  291.         thestrings !
  292.     THEN
  293. ;
  294.  
  295.  
  296. : $ft.save-icon ( adr-forth-string -- )
  297.     \ AGAIN...do not append the '.info'
  298.     ft.icon-open?  COUNT >DOS DOS0    theIcon @  PutDiskObject() 0= IF
  299.         " ERROR while saving DiskObject!" con.write.itl con.cr
  300.         ft.abort
  301.     THEN
  302.     theIcon @  FreeDiskObject()  theIcon OFF  thestrings @ FREEBLOCK
  303. ;
  304.  
  305.  
  306. \ *** support ***
  307.  
  308. : ft.greeting    ( -- )
  309.     " Release icons to be freely placed by Workbench." con.write.itl con.cr
  310.     " (c) Copyright by Richard Mazzarisi 1989, 1990" con.write.c3 con.cr
  311.     "          All rights reserved." con.write.c3 con.cr
  312.     "      Written in JForth Professional 2.0." con.write.c3 con.cr con.cr
  313. ;
  314.  
  315.  
  316. : prt.instr    ( -- )
  317.     " Instructions:"  con.write con.cr
  318.     " 1 - Click on the icon for this program."  con.write con.cr
  319.     " 2 - Shift click on all the icons to be floated."  con.write con.cr
  320.     con.cr
  321.     " (NOTE: The author assumes no responsibility for any"
  322.     con.write con.cr
  323.     " damages resulting from the use of this program.)" con.write con.cr
  324. ;
  325.  
  326.  
  327. : check.WB    ( -- )
  328.     \ check if running under WorkBench?
  329.     WBMESSAGE @ NOT IF
  330.         " Must be run under the WorkBench!" con.write.itl con.cr con.cr
  331.         prt.instr  ft.abort
  332.     THEN
  333. ;
  334.  
  335.  
  336. : check.num.args    ( -- n t | f )
  337. \ We need at least two args to make any sense.
  338. \ returns number of arguments and true; or false if not enough
  339.     WBMESSAGE @ >REL ..@ sm_NumArgs  DUP 2 <  IF
  340.         \ not enough args; tell'em how
  341.         " You must click on at least one other icon!" con.write.itl con.cr con.cr
  342.         prt.instr  prt.close-msg
  343.         DROP FALSE
  344.     ELSE
  345.         1-  ( 1st is FloatIcon )
  346.         TRUE
  347.     THEN
  348. ;
  349.  
  350.  
  351. : alloc.fib    ( -- fib-addr )
  352.     \ allocate memory for the File Info Block
  353.     MEMF_CLEAR  SizeOf() FileInfoBlock  ALLOCBLOCK
  354.     DUP NULL = IF
  355.         " ERROR: Could not allocate FileInfoBlock!" con.write.itl
  356.     THEN
  357. ;
  358.  
  359.  
  360. : dealloc.fib    ( fib-addr -- )
  361.     DUP IF
  362.         FREEBLOCK
  363.     THEN
  364. ;
  365.  
  366.  
  367. : get.parentdir     { lock | fib pdirflg dirflg ok --> dirflg ok }
  368. \ return in dirflg t if parent is a directory, f if it is disk (root) and t/f
  369. \ obviously dirflg is useless if all is not OK
  370.     TRUE -> ok  TRUE -> dirflg
  371.     alloc.fib  DUP -> fib  IF
  372.         \ go upward recursively
  373.         lock ParentDir()  -DUP IF
  374.             DUP fib Examine()  DROP
  375.             RECURSE  SWAP -> pdirflg  IF
  376.                 fib .. fib_FileName  0COUNT  build.name
  377.                 pdirflg IF
  378.                     " /" COUNT  build.name
  379.                 ELSE
  380.                     " :" COUNT  build.name
  381.                 THEN
  382.             ELSE
  383.                 FALSE -> ok
  384.             THEN
  385.         ELSE
  386.             \ stop! reached the root dir, i.e. 'disk:'
  387.             FALSE -> dirflg
  388.         THEN
  389.         fib dealloc.fib
  390.     ELSE
  391.         FALSE -> ok
  392.     THEN
  393. ;
  394.  
  395.  
  396. : remove.final.slash          ( stradd -- )
  397. \ get rid of final slash or colon on the name if there
  398.     DUP C@
  399.     OVER + C@  ASCII / =  IF
  400.         DUP C@ 1-  SWAP C!
  401.     ELSE
  402.         DROP
  403.     THEN
  404. ;
  405.  
  406.  
  407. : ?dev_name         ( stradd -- )
  408. \ return true if name ends in a colon
  409.     DUP C@
  410.     SWAP + C@  ASCII : =
  411. ;
  412.  
  413.  
  414. : get.full-path     { wbarg | fib pdirflg ok --> ok }
  415. \ full path of file is written into PAD
  416.     init.name
  417.     TRUE -> ok
  418.     alloc.fib  DUP -> fib  IF
  419.         \ get the directory path
  420.         wbarg ..@ wa_Lock  fib    Examine()  DROP
  421.         wbarg ..@ wa_Lock get.parentdir  SWAP -> pdirflg  IF
  422.             \ get directory name
  423.             fib .. fib_FileName  0COUNT  build.name
  424.             pdirflg IF
  425.                 " /" COUNT  build.name
  426.             ELSE
  427.                 " :" COUNT  build.name
  428.             THEN
  429.             \ get name
  430.             wbarg ..@ wa_Name >REL 0COUNT  build.name
  431.         ELSE
  432.             FALSE -> ok
  433.         THEN
  434.         fib dealloc.fib
  435.         PAD remove.final.slash
  436.         PAD ?dev_name IF
  437.             \ possibly a disk; try...
  438.             " Disk" COUNT build.name
  439.         THEN
  440.     ELSE
  441.         FALSE -> ok
  442.     THEN
  443. ;
  444.  
  445.  
  446. : float.it    ( -- )
  447.     PAD $ft.get-icon
  448. [ clone-it @ ] .IF
  449.     SET-NO-POSITION
  450.     PAD $ft.save-icon
  451. .ELSE
  452. \ don't really do it if we are testing things in the interpreter
  453.     ft.abort-icon
  454. .THEN
  455. ;
  456.  
  457.  
  458. : float.one    { wbarg -- }
  459.     \ get file's path name
  460.     wbarg get.full-path IF
  461.         "   " con.write
  462.         PAD con.write con.cr
  463.         float.it
  464.     ELSE
  465.         " ERROR: Could not get path for project:" con.write.itl con.cr
  466.         "   " con.write
  467.         wreq @ wbarg ..@ wa_Name >REL ConPutStr() con.cr
  468.     THEN
  469. ;
  470.  
  471.  
  472. : do.floats    { #args -- }
  473.     \ get pointer to args
  474.     WBMESSAGE @ >REL ..@ sm_ArgList >REL
  475.     \ 2rd and on are the icons to be floated
  476.     #args 1+  1  DO
  477.         DUP  SizeOf() WBArg  I *  +
  478.         float.one
  479.         \ check for stop action
  480.         ?CLOSEBOX IF LEAVE THEN
  481.     LOOP
  482.     DROP
  483.     con.cr " Done.  " con.write.itl
  484. ;
  485.  
  486.  
  487. \ *** main ***
  488.  
  489. : floaticon   ( -- )
  490.     open.ft-things
  491.     cursor.off
  492.     ft.greeting
  493.     check.WB
  494.     check.num.args IF
  495.         do.floats
  496.         " Click CloseBox to exit." con.write
  497.     THEN
  498.     close.ft-things
  499. ;
  500.  
  501.  
  502. : ft
  503.     floaticon
  504. ;
  505.  
  506.  
  507. clone-it @ .IF
  508.  
  509. initclone
  510. clone ft
  511. save-image FloatIcon FloatIcon -icon
  512.  
  513. .THEN
  514.  
  515. CR CR ." Type 'ft' to run." CR CR
  516.