/hmsl/fth/ctrl_text.fth

https://github.com/philburk/hmsl · Forth · 596 lines · 529 code · 67 blank · 0 comment · 8 complexity · 31f6cce8f50e3e04e6102f52891a6ac0 MD5 · raw file

  1. \ Text Input Control
  2. \ Define a grid of text input items.
  3. \
  4. \ Author: Phil Burk
  5. \ Copyright 1991 Phil Burk
  6. \
  7. \ 00001 PLB 2/6/92 Use EXEC.STACK?
  8. ANEW TASK-CTRL_TEXT
  9. decimal
  10. \ -----------------------------------------------
  11. : $INSERT.CHAR { char cursor $string -- }
  12. \
  13. \ check for string overflow
  14. $string c@ 255 = abort" $INSERT.CHAR - string is full!"
  15. \
  16. \ check for past end
  17. $string c@ cursor
  18. < abort" $INSERT.CHAR - cursor past end of string!"
  19. \
  20. \ move characters up
  21. $string c@ cursor >
  22. IF
  23. $string 1+ cursor + \ source
  24. dup 1+ \ dest
  25. $string c@ cursor - \ many
  26. move
  27. THEN
  28. \
  29. \ put in character
  30. char $string 1+ cursor + c!
  31. \
  32. \ increment count
  33. $string c@ 1+ $string c!
  34. ;
  35. : $REMOVE.CHAR { cursor $string -- }
  36. \ check for past end
  37. $string c@ cursor
  38. < abort" $REMOVE.CHAR - cursor past end of string!"
  39. \
  40. \ move characters down
  41. cursor 0>
  42. IF
  43. $string 1+ cursor + \ source
  44. dup 1- \ dest
  45. $string c@ cursor - \ many
  46. move
  47. \
  48. \ decrement count
  49. $string c@ 1- $string c!
  50. THEN
  51. ;
  52. : $CHOP.RANGE { start end $string -- }
  53. \ check for past end
  54. $string c@ start end max
  55. < abort" $CHOP.RANGE - cursor past end of string!"
  56. \
  57. \ move characters down
  58. end 0>
  59. IF
  60. $string 1+ end + \ source
  61. $string 1+ start + \ dest
  62. $string c@ end - \ many
  63. move
  64. \
  65. \ decrement count
  66. $string c@ end start - - $string c!
  67. THEN
  68. ;
  69. \ -----------------------------------------------
  70. \ One Line Text Editing Control
  71. METHOD PUT.CR.FUNCTION:
  72. METHOD GET.CR.FUNCTION:
  73. METHOD PUT.FILTER.FUNCTION:
  74. METHOD GET.FILTER.FUNCTION:
  75. METHOD PUT.LEAVE.FUNCTION:
  76. METHOD GET.LEAVE.FUNCTION:
  77. METHOD PUT.JUSTIFY:
  78. METHOD GET.JUSTIFY:
  79. 0 value CG_TXED_START
  80. 0 value CG_TXED_END
  81. 0 value CG_TXED_ANCHOR
  82. 0 value CG_TXED_LAST
  83. 0 value CG_TXED_PART \ currently highlighted part
  84. :CLASS OB.TEXT.GRID <SUPER OB.CONTROL.GRID
  85. iv.long IV-CG-TEXT-CR-CFA
  86. iv.long IV-CG-TEXT-FILTER-CFA
  87. iv.long IV-CG-TEXT-LEAVE-CFA
  88. iv.short IV-CG-TEXT-MAX \ maximum number of characters in string
  89. iv.short IV-CG-TEXT-JUST \ 0,1,2 for left,center,right justify
  90. ob.barray IV-CG-TEXT-BUF \ contains N Forth strings
  91. :M PUT.CR.FUNCTION: ( cfa -- )
  92. iv=> iv-cg-text-cr-cfa
  93. ;M
  94. :M GET.CR.FUNCTION: ( -- cfa )
  95. iv-cg-text-cr-cfa
  96. ;M
  97. :M PUT.FILTER.FUNCTION: ( cfa -- )
  98. iv=> iv-cg-text-filter-cfa
  99. ;M
  100. :M GET.FILTER.FUNCTION: ( -- cfa )
  101. iv-cg-text-filter-cfa
  102. ;M
  103. :M PUT.LEAVE.FUNCTION: ( cfa -- )
  104. iv=> iv-cg-text-leave-cfa
  105. ;M
  106. :M GET.LEAVE.FUNCTION: ( -- cfa )
  107. iv-cg-text-leave-cfa
  108. ;M
  109. :M PUT.JUSTIFY: ( justification -- )
  110. iv=> iv-cg-text-just
  111. ;M
  112. :M GET.JUSTIFY: ( -- justification )
  113. iv-cg-text-just
  114. ;M
  115. :M GET.TEXT: ( part -- $text )
  116. iv-cg-text-max 1+ * data.addr: iv-cg-text-buf +
  117. ;M
  118. : CT.CUR.TEXT ( -- $text )
  119. cg_txed_part get.text: self
  120. ;
  121. :M PUT.TEXT: ( $text part -- )
  122. over c@ iv-cg-text-max >
  123. IF
  124. . $type ." too long in PUT.TEXT: " name: self cr
  125. ELSE
  126. 0 -> cg_txed_start \ highlight entire text
  127. over c@ -> cg_txed_end
  128. get.text: self $move
  129. THEN
  130. ;M
  131. :M GET.VALUE: ( part -- n )
  132. get.text: self number?
  133. IF
  134. drop
  135. ELSE
  136. ." Invalid number in " name: self cr
  137. 0 \ have to return something !
  138. THEN
  139. ;M
  140. :M PUT.VALUE: ( n part -- )
  141. get.text: self >r
  142. n>text ( addr count )
  143. dup r@ c!
  144. r> 1+ swap cmove
  145. ;M
  146. :M INIT:
  147. init: super
  148. 0 iv=> iv-cg-text-max
  149. 0 iv=> iv-cg-text-cr-cfa
  150. 0 iv=> iv-cg-text-filter-cfa
  151. ;M
  152. :M NEW: ( numx numy numchars -- )
  153. >r 2dup .s new: super
  154. * r> dup iv=> iv-cg-text-max \ remember new: calls SELF FREE: []
  155. 1+ * new: iv-cg-text-buf
  156. clear: iv-cg-text-buf
  157. ;M
  158. :M FREE:
  159. free: super
  160. free: iv-cg-text-buf
  161. 0 iv=> iv-cg-text-max
  162. ;M
  163. 3 value CT_TEXT_DESCENT
  164. : CT.PART>XY { part | x1 y1 x2 y2 -- x y }
  165. part get.rect: self -> y2 -> x2 -> y1 -> x1
  166. iv-cg-text-just
  167. CASE
  168. 0 OF x1 2+ y2 ct_text_descent - ENDOF
  169. 1 OF x2 x1 + 2/ \ center
  170. part get.text: self count gr.textlen 2/ -
  171. y2 ct_text_descent -
  172. ENDOF
  173. 2 OF x2 4 -
  174. part get.text: self count gr.textlen -
  175. y2 ct_text_descent -
  176. ENDOF
  177. ENDCASE
  178. ;
  179. : CT.BASE.XY ( -- x y )
  180. cg_txed_part ct.part>xy
  181. ;
  182. : CT.INDEX>XY ( index -- x y )
  183. ct.cur.text 1+ swap gr.textlen
  184. ct.base.xy >r + r>
  185. ;
  186. : IN.RECT? { mx my x1 y1 x2 y2 -- in_rectangle? }
  187. mx x1 x2 within? dup
  188. IF
  189. drop
  190. my y1 y2 within?
  191. THEN
  192. ;
  193. : CT.XY>INDEX { mx my | indx x1 y1 x2 y2 -- indx true | false }
  194. cg_txed_part get.rect: self -> y2 -> x2 -> y1 -> x1
  195. my y1 y2 within?
  196. IF
  197. mx ct.base.xy drop - -> mx \ offset from first char
  198. \ scan all characters in case we have a proportional font
  199. ct.cur.text c@ dup -> indx 0
  200. ?DO
  201. ct.cur.text 1+ i 1+ gr.textlen
  202. mx >
  203. IF
  204. i -> indx
  205. LEAVE
  206. THEN
  207. LOOP
  208. indx true
  209. ELSE
  210. FALSE
  211. THEN
  212. ;
  213. : CT.HIGHLIGHT ( -- , highlight selected region )
  214. gr.mode@
  215. gr.color@
  216. cg_txed_start ct.index>xy gr.height@ -
  217. cg_txed_end ct.index>xy ( -- x1 y1 x2 y2 )
  218. \
  219. \ force minimum width of 3 pixels
  220. >r 2 pick 3 + max r>
  221. \
  222. \ draw in XOR mode
  223. gr_xor_mode gr.mode!
  224. gr_white gr.color!
  225. gr.rect
  226. gr.color!
  227. gr.mode!
  228. ;
  229. :M DRAW.PART: ( part -- )
  230. dup clear.part: self
  231. dup ct.part>xy gr.move
  232. dup get.text: self gr.text
  233. iv-cg-active
  234. IF
  235. dup cg_txed_part =
  236. IF ct.highlight
  237. THEN
  238. THEN
  239. drop
  240. ;M
  241. : CT.CHOP ( -- , chop selected range )
  242. cg_txed_start cg_txed_end
  243. 2dup -
  244. IF
  245. ct.cur.text $chop.range
  246. cg_txed_start -> cg_txed_end
  247. ELSE
  248. 2drop
  249. THEN
  250. ;
  251. : CT.DELETE ( -- , delete char in front of cursor )
  252. cg_txed_start cg_txed_end
  253. 2dup -
  254. IF
  255. ct.cur.text $chop.range
  256. ELSE
  257. \ no text range selected
  258. drop 1+ dup ct.cur.text c@ <= \ before end?
  259. IF
  260. ct.cur.text $remove.char
  261. ELSE drop
  262. THEN
  263. THEN
  264. cg_txed_start -> cg_txed_end
  265. ;
  266. : CT.BACKSPACE ( -- )
  267. cg_txed_start cg_txed_end
  268. 2dup -
  269. IF
  270. ct.cur.text $chop.range
  271. cg_txed_start -> cg_txed_end
  272. ELSE
  273. \ no text range selected
  274. drop
  275. ct.cur.text $remove.char
  276. cg_txed_start 1- 0 max
  277. dup -> cg_txed_start -> cg_txed_end
  278. THEN
  279. ;
  280. : CT.INSERT { char | xl xr x1 x2 -- }
  281. ct.chop
  282. ct.cur.text c@ iv-cg-text-max <
  283. IF
  284. char cg_txed_start ct.cur.text $insert.char
  285. cg_txed_start 1+
  286. dup -> cg_txed_start -> cg_txed_end
  287. \
  288. \ check for past end of box
  289. ct.base.xy drop -> xl \ start of text
  290. xl ct.cur.text count gr.textlen + -> xr \ end of text
  291. cg_txed_part get.rect: self drop -> x2 drop -> x1
  292. xL x1 x2 within? not \ left edge outside box ?
  293. xR x1 x2 within? not OR \ right edge outside box ?
  294. IF
  295. ct.backspace beep
  296. THEN
  297. THEN
  298. ;
  299. : CT.LEFT ( -- , move cursor one to left )
  300. cg_txed_start 1- 0 max -> cg_txed_start
  301. cg_txed_start -> cg_txed_end
  302. ;
  303. : CT.RIGHT ( -- , move cursor one to right )
  304. cg_txed_start 1+ ct.cur.text c@ min -> cg_txed_start
  305. cg_txed_start -> cg_txed_end
  306. ;
  307. : CT.SHIFT.LEFT ( -- , move cursor fully to left )
  308. 0 dup -> cg_txed_start
  309. -> cg_txed_end
  310. ;
  311. : CT.SHIFT.RIGHT ( -- , move cursor fully to right )
  312. ct.cur.text c@ dup -> cg_txed_start
  313. -> cg_txed_end
  314. ;
  315. $ 7F constant DELETE_CHAR
  316. : CT.DO.KEY { character | redraw? -- , do editing based on char }
  317. true -> redraw?
  318. ct.highlight
  319. character
  320. CASE
  321. \
  322. character isprint
  323. ?OF character ct.insert
  324. ENDOF
  325. \
  326. 8
  327. OF ct.backspace
  328. ENDOF
  329. \
  330. delete_char
  331. OF ct.delete
  332. ENDOF
  333. \
  334. left_arrow OF ct.left ENDOF
  335. right_arrow OF ct.right ENDOF
  336. shift_left_arrow OF ct.shift.left ENDOF
  337. shift_right_arrow OF ct.shift.right ENDOF
  338. \
  339. $ 0D \ carriage return
  340. OF
  341. iv-cg-text-cr-cfa ?dup
  342. IF >r ct.cur.text cg_txed_part r>
  343. -2 exec.stack?
  344. THEN
  345. false -> redraw?
  346. ENDOF
  347. ENDCASE
  348. redraw?
  349. IF
  350. cg_txed_part draw.part: self
  351. THEN
  352. ;
  353. :M KEY: ( character -- )
  354. \ decide whether this is an OK character
  355. iv-cg-text-filter-cfa ?dup
  356. IF >r dup r> 0 exec.stack?
  357. ELSE true
  358. THEN ( char ok? )
  359. \
  360. IF
  361. ct.do.key
  362. ELSE
  363. drop beep
  364. THEN
  365. ;M
  366. : CT.DO.LEAVE ( n -- , execute LEAVE function )
  367. iv-cg-text-leave-cfa ?dup
  368. IF >r dup get.text: self swap r>
  369. -2 exec.stack?
  370. ELSE drop
  371. THEN
  372. ;
  373. : CT.UPDATE.STATUS ( -- update control variables )
  374. iv-cg-lasthit -> cg_txed_part
  375. cg-first-mx @ cg-first-my @ ct.xy>index not
  376. IF 0
  377. THEN
  378. dup -> cg_txed_end
  379. dup -> cg_txed_start
  380. dup -> cg_txed_anchor
  381. -> cg_txed_last
  382. ;
  383. :M PUT.ACTIVE: ( flag -- , make selected, handle highlighting )
  384. depth 1- >r
  385. \ turn off current highlighting if any
  386. iv-cg-drawn iv-cg-active and
  387. IF
  388. ct.highlight
  389. cg_txed_part ct.do.leave
  390. THEN
  391. \
  392. dup put.active: super
  393. \
  394. \ change select and highlighting info
  395. IF
  396. ct.update.status
  397. \
  398. \ highlight if now active
  399. iv-cg-drawn
  400. IF
  401. ct.highlight
  402. THEN
  403. \
  404. \ no part currently active
  405. ELSE
  406. -1 -> cg_txed_part
  407. THEN
  408. depth r> - abort" MOUSE.DOWN: - stack change!"
  409. ;M
  410. :M MOUSE.DOWN: ( x y -- trapped? )
  411. depth 1- >r
  412. mouse.down: super
  413. \
  414. \ If the same control is still active, but we have moved to
  415. \ a new part, then call LEAVE.FUNCTION
  416. dup
  417. IF
  418. iv-cg-active
  419. IF
  420. cg_txed_part iv-cg-lasthit = not
  421. IF
  422. cg_txed_part ct.do.leave
  423. THEN
  424. \
  425. \ we know we are active so change highlighting
  426. iv-cg-drawn
  427. IF
  428. ct.highlight
  429. ct.update.status
  430. ct.highlight
  431. THEN
  432. THEN
  433. THEN
  434. \
  435. ev.track.on
  436. depth r> - abort" MOUSE.DOWN: - stack change!"
  437. ;M
  438. :M MOUSE.MOVE: ( x y -- )
  439. 2dup mouse.move: super
  440. ct.xy>index
  441. IF
  442. dup cg_txed_last - \ has the index changed, prevent flicker
  443. IF
  444. ct.highlight
  445. dup -> cg_txed_last
  446. cg_txed_anchor 2sort
  447. -> cg_txed_end -> cg_txed_start
  448. ct.highlight
  449. ELSE drop
  450. THEN
  451. THEN
  452. ;M
  453. :M MOUSE.UP: ( x y -- )
  454. mouse.up: super
  455. ev.track.off
  456. ;M
  457. :M PRINT: ( -- )
  458. print: super
  459. many: self 0
  460. ?DO
  461. i . i get.text: self $type cr
  462. LOOP
  463. ;M
  464. ;CLASS
  465. : CT.FILTER.NUMERIC ( char -- ok? , filter characters for number )
  466. >r
  467. r@ isdigit
  468. r@ ascii . = OR
  469. r@ ascii , = OR
  470. r@ ascii - = cg_txed_start 0= AND OR
  471. r@ toupper ascii E = OR
  472. r@ isprint not OR
  473. rdrop
  474. ;
  475. : CT.FILTER.NOTE ( key -- ok? )
  476. >r
  477. r@ isprint not
  478. r@ tolower ascii a ascii g within? OR
  479. r@ tolower ascii # = OR
  480. r@ isdigit OR
  481. rdrop
  482. ;
  483. false [IF]
  484. OB.TEXT.GRID CT1
  485. OB.TEXT.GRID CT2
  486. OB.MENU.GRID RG1
  487. OB.SCREEN SCR1
  488. : SHOW.TEXT ( $text part -- )
  489. . ." Text = " $type cr
  490. ;
  491. : SHOW.VALUE ( $text part -- )
  492. . ." Value = " number?
  493. IF
  494. d.
  495. ELSE
  496. ." Bad!"
  497. THEN
  498. cr
  499. ;
  500. : CT.INIT
  501. 2 2 new: rg1
  502. 200 200 put.wh: rg1
  503. \
  504. 2 2 20 new: ct1
  505. 600 300 put.wh: ct1
  506. 'c show.text put.cr.function: ct1
  507. \
  508. 1 4 20 new: ct2
  509. 600 300 put.wh: ct2
  510. 'c ct.filter.numeric put.filter.function: ct2
  511. 'c show.value put.cr.function: ct2
  512. 'c show.value put.leave.function: ct2
  513. 4 3 new: scr1
  514. ct1 200 400 add: scr1
  515. ct2 2000 400 add: scr1
  516. rg1 200 3000 add: scr1
  517. scr1 default-screen !
  518. ;
  519. : CT.TERM
  520. freeall: scr1
  521. free: scr1
  522. ;
  523. if.forgotten ct.term
  524. : CT.TEST
  525. ct.init
  526. hmsl
  527. ct.term
  528. ;
  529. [THEN]