\ input 98.12.7 8:10 pm NAB
\ Provides a standard dialog for
\ text input.  Requires
\ 'Qrsrc.PRC' to be installed.

needs graphics
needs core-ext
needs Fonts
needs Events
needs Forms
needs Fields
needs zstrings
needs resources

(ID) p4ap (ID) util use-resources

4000 constant inputFormID
4001 constant inputFieldID

2variable inputfldptr

: inputfldlen ( -- len )
  inputfldptr 2@
  FldGetTextLength ;

: center-title ( c-addr u -- )
  boldFont font >r
    swap 2dup >abs FntCharsWidth
    2/ negate 80 +  0 swap  2swap >abs
    WinDrawInvertedChars
  r> font drop ;

: get-input
\ ( a1 u1 max a2 u2 a3 u3
\    -- false | u4 true )
\ a1 u1: input string
\ max: max chars allowed
\ a2 u2: prompt string
\ a3 u3: title string
\ u4: new length
  cursor-position 2>r
  FrmGetActiveFormID >r
  inputFormID PopupForm
  center-title
  21 7 at  type  \ prompt string
  inputFieldID FieldFocus
\ Set max. field length:
  inputFieldID GetObjectPtr
  2dup inputfldptr 2!  \ for later
  FldSetMaxChars
  2dup
  inputFieldID string>Field drop
\ Loop until a button pressed:
  begin
    ekey ctlSelectEvent = if
      drop  inputfldlen swap
      event >abs itemid if  \ OK button
        inputFieldID Field>string drop
        true
      else  2drop false  then
      r> FrmReturnToForm
      2r> at  exit
    then
  again ;

\ Example:
needs tools-ext
1 [if]
: string s" default" ;  40 allot
: test
  string  2dup
  40 s" Prompt:" s" Title" get-input
  cr if
    ." You entered: " nip  type
  else  ." Cancelled." 2drop  then  cr ;
[then]