home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Toolbox classes / TextEdit < prev    next >
Encoding:
Text File  |  1995-12-10  |  6.6 KB  |  299 lines  |  [TEXT/MSET]
  1. \ Oct95 JRF Added noClip to Activate: & Deactivate: per MRH suggestion
  2.     \ modified New: to enable outline highliting of inactive TE
  3.  
  4. \ 25May93 DBH  Added lastchar: to commonize a routine.
  5.     \ added kludge to #lines: to fix a bug.
  6.     \ Completely reworked currentline: to fix a speed problem.
  7.  
  8. \ 15May93 DBH  Added textaddr: method to improve readability and code reuse.
  9.     \ Use textaddr: self in getline: .
  10.     \ Deleted addrlinestart: method because it is never reused.
  11.     \ Added lineEnd: method, so we can move there easily.
  12.     \ Delte general class declaration.
  13. \ 11May93 DBH  fixed getLine: so null is returned if last char in TE is
  14.     \ a carriage return.  Added getpoint: and idle: methods.
  15.  
  16. need terecord
  17.  
  18. \ some routines to handle the clipboard
  19.  
  20. : TODESK        ( -- oserr )
  21.         0 call ZeroScrap IF exit THEN \ out if error
  22.         0       \ room for oserr
  23.         global TEScrpLength w@  \ length
  24.         'type TEXT      \ theType
  25.         global TEScrpHandle @ @
  26.         call PutScrap
  27.         ;
  28.  
  29. variable OFFSET  \ used in GetScrap call
  30.  
  31.  : FROMDESK     ( -- oserr )
  32.     0 \ room for result
  33.         global TEScrpHandle @
  34.         'type TEXT      \ theType
  35.         offset
  36.         call GetScrap
  37.         dup 0>= IF global TEScrpLength w! \ store scrap length
  38.                            false  \ no error
  39.                         THEN
  40.         ; 
  41.  
  42.  
  43.  
  44. : SELCUT
  45.         actW IF cut: [ actW ] THEN ;
  46.  
  47. : SELCOPY
  48.         actW IF copy: [ actW ] THEN ;
  49.  
  50. : SELPASTE
  51.     actW IF  paste: [ actW ]  THEN ;
  52.  
  53. : SELCLEAR
  54.     actW IF  clear: [ actW ]  THEN ;
  55.  
  56.  
  57.  
  58. :CLASS TextEdit super{ object }
  59.  
  60.     handle    TEHandle
  61.  
  62. :m new:    { dest view -- }
  63.     0    \ space for returned handle
  64.     dest
  65.     view
  66.     call TENew
  67.     put: TEHandle
  68.     word0 2 1 pack        \ 2 selects OutlineHilite feature
  69.     get: TEHandle        \ 1 sets its flag
  70.     call TEFeatureFlag
  71.     makeint    ;m            \ drop the returned int
  72.  
  73. :m handle:    ( -- tehandle )
  74.     get: TEHandle ;m
  75.  
  76. :m ptr:    ( -- teRecord )
  77.     ptr: TEHandle ;m
  78.  
  79.  
  80. :m noWrap:    \ **
  81.     ptr: self  noWrap: teRecord  ;m
  82.  
  83. :m WrapIt:
  84.     ptr: self  wrapIt: teRecord  ;m
  85.  
  86.  
  87. :m SETVIEWRECT:  { left top rt bot \ adr -- }
  88.     ptr: TEHandle  -> adr    \ ptr: TEHandle setview: teRecord ;m  ??    \ 19May93 DBH
  89.     top  adr  8 +  w!  left  adr 10 + w!
  90.     bot  adr 12 +  w!    rt  adr 14 + w!  ;m
  91.  
  92.  
  93. :m LINEHEIGHT:  ( -- n )
  94.     ptr: TEHandle lineHeight: teRecord ;m
  95.  
  96. \ :m #lines:    ( -- n)
  97. \    ptr: TEHandle  #lines: teRecord    \ note message to class
  98. \    ;m
  99.  
  100. :m cut:
  101.     get: TEHandle call TECut
  102.     todesk  drop ;m \ not looking at error
  103.  
  104. :m copy:
  105.     get: TEHandle call TECopy
  106.     todesk drop ;m \ not looking at error
  107.  
  108. :m paste:
  109.     fromdesk IF exit THEN \ out if error
  110.     get: TEHandle call TEPaste ;m
  111.  
  112. :m clear:
  113.     0  call SetOrigin
  114.     get: TEHandle call TEDelete ;m
  115.  
  116. :m update:    \ ( rptr -- )
  117.     0  call SetOrigin
  118.     get: TEHandle
  119.     call TEUpdate
  120. ;m
  121.     
  122. :m SCROLL:        \ ( dx dy -- )
  123.     0  call SetOrigin
  124.     pack  get: TEHandle  call TEScroll  ;m
  125.  
  126.  
  127. :m size: ( -- len )  \ returns the length of the text
  128.     ptr: TEHandle  size: teRecord ;m         \ note message to class
  129.  
  130. :m TextHandle:        \ ( -- hndl )
  131.     0 get: TEhandle  call TEGetText  ;m
  132.  
  133. :m textaddr:        \ ( -- $addr )    \ addr of the first char of the TE text
  134.     textHandle: self  @  ;m
  135.  
  136. :m get:    ( -- $addr len )
  137.     textaddr: self
  138.     size: self  ;m
  139.  
  140. :m put: ( $addr len -- )
  141.     get: TEHandle  call TESetText
  142.     update: self  ;m
  143.  
  144. :m insert: ( $addr len -- )
  145.     get: TEHandle  call TEInsert
  146.     ;m
  147.  
  148. :m activate:
  149.     noClip
  150.     get: TEHandle call TEActivate ;m
  151.  
  152. :m deactivate:
  153.     noClip
  154.     get: TEHandle  call TEDeactivate ;m
  155.  
  156. :m release:
  157.     get: TEHandle call TEDispose
  158.     clear: TEHandle ;m
  159.  
  160. :m click:
  161.     where: fEvent  g->l
  162.     mods: fevent $ 200 and makeint      \ extend if shift key
  163.     handle: self  call TEClick
  164.     ;m
  165.  
  166. :m select:  ( start end -- )  \ hilites the given range
  167.     get: TEHandle  call TESetSelect ;m
  168.  
  169. :m selectAll:  \ hilites all of the text
  170.     0 ( start)
  171.     size: self  ( end)
  172.     select: self ;m
  173.  
  174. :m selStart:  ( -- n )
  175.     ptr: TEHandle selStart: teRecord ;m
  176.  
  177. :m selEnd:  ( -- n )
  178.     ptr: TEHandle selEnd: teRecord ;m
  179.  
  180. :m lastchar:  ( -- char )    \ return last character in TE
  181.     textaddr: self  size: self 1- + c@  ;m
  182.  
  183.  
  184. :m key:  { char \ bSel eSel -- }
  185.         \ TE for some reason doesn't handle forward delete, so we
  186.         \  have to special-case it.
  187.  
  188.     char 127 =
  189.     IF                            \ yes, it's forward delete
  190.         selStart: self -> bSel
  191.         selEnd: self   -> eSel
  192.         bSel eSel =
  193.         IF    eSel  size: self  >=  ?EXIT
  194.             eSel 1+ dup  select: self
  195.         ELSE
  196.             eSel  size: self <
  197.             IF  bSel eSel 1+  select: self  THEN
  198.         THEN
  199.         8  -> char
  200.     THEN
  201.     char makeint
  202.     get: TEHandle
  203.     call TEKey  ;m
  204.  
  205.  
  206. 0 value kludge
  207.  
  208. :m #lines:    ( -- n)
  209.     0 -> kludge
  210.     ptr: TEHandle  #lines: teRecord    \ note message to class
  211.     lastchar: self  ret = IF -1 -> kludge 1+ THEN    \ kludge Apple line numbering scheme!!
  212.     ;m
  213.  
  214. \ given the zero-based line number, return the character# of the start of
  215. \ that line
  216.  
  217. :m at:  { n -- linestart }
  218.     n kludge + 1 +  #lines: self > abort" TE linestart index out of range"
  219.     
  220.     ptr: TEHandle addrLineStart: teRecord  n 2 * + w@ ;m
  221.  
  222. :m GETPOINT:  { offset -- x y }    \ given the char offset into the text, return the
  223.                                 \ corresponding x y location  See IM V-269.
  224.     0 offset makeint get: TEHandle call TEGetPoint  unpack ;m
  225.  
  226. :m currentLine:     ( -- n )    \ **
  227.     selend: self GETPOINT: self  ( x y ) nip          ( cursor.y )
  228.     ptr: TEHandle ( dest) gettopy: rect  -        ( cursor.y - dest.top )
  229.     
  230.     lineheight: self / 1-
  231.     
  232.     selend: self  size: self =     \ true if at last char
  233.     size: self  and    \ and if not an empty size
  234.     IF
  235.         lastchar: self  ret =
  236.         IF    \ uh-oh, handle special case where last char is a ret
  237.             1+
  238.         THEN
  239.     THEN
  240.     ;m
  241.  
  242. :m getLine:  { \ l -- addr len }
  243.     size: self 0= IF pad 0 exit    THEN    \ return nil and get out if no text
  244.     currentLine: self -> l
  245.     #lines: self 1 - l =
  246.     IF                                    \ we are on the last line
  247.         lastchar: self
  248.         ret =
  249.             IF        \ we are on the last line AND just beyond a carriage return!
  250.                 pad 0 exit                \ return nil and get out here
  251.             THEN
  252.  
  253.         textaddr: self  l at: self +  ( addr )
  254.         size: self
  255.         l at: self -  ( len)
  256.     
  257.     ELSE
  258.     
  259.         textaddr: self  l at: self +  ( addr )
  260.         
  261.         l 1 + at: self
  262.         l at: self - 1 -  ( len )
  263.     THEN
  264.     ;m
  265.  
  266. :m LINEEND: { \ len pos -- pos }    \ return the character position corresponding to the
  267.                             \ end of the last line of the current selection.
  268.     selend: self size: self =
  269.     IF    \ we are at the end of the text
  270.         size: self
  271.     ELSE
  272.         currentline: self  at: self  ( linestart ) -> pos
  273.         getline: self nip -> len
  274.         pos len +
  275.     THEN ;m
  276.  
  277. :m getselect: ( -- addr len )    \ returns hilited selection
  278.     ptr: TEHandle    getselect: teRecord ;m
  279.  
  280.  
  281. :m IDLE:    \ May94 mh - Setting cursor now moved to TEScroller
  282.     get: TEHandle call TEIdle    
  283.  ;m
  284.  
  285. :m DUMP:
  286.     selstart: self
  287.     selend: self
  288.     currentline: self
  289.     lineEnd: self
  290.     size: self  { ss se cl le sz -- }
  291. \    ss " selstart "        >debug
  292. \    se " selend "            >debug
  293. \    cl " currentline "     >debug
  294. \    le " lineEnd "         >debug
  295. \    sz " size "             >debug
  296. ;m
  297.  
  298. ;CLASS
  299.