-13 >ifflag
   128 0 reserve
>endf

variable p
variable q
variable r

\ -----------------------
\  Chargements Ressources
\ -----------------------
: HEADER
   [var]
   1 >include "%SAVERTF.RSC"
;

>comp

HEADER rsrc_rcfix

%b11101 >include "%SAVERTF.DEF"

>comp
\ ------------------------
\ module de sauvegarde RTF
\ ------------------------

>fom RTFsave,RTFmode,RTFfont,RTFtab

: MOD_RTF
   17 >include "D:\PARX.SYS\FORTH\RTF.FOM"
;

MOD_RTF p ! 1 p modload drop

>comp
\ -----------------------------
\ module gestion fichier Config
\ -----------------------------

>fom CFGset,CFGfree,CFGload,CFGsave,CFGcreate
>fom CFGgetkey,CFGsetkey,CFGdelkey

: MOD_CFG
   17 >include "D:\PARX.SYS\FORTH\CONFIG.FOM"
;

MOD_CFG q ! 1 q modload drop

>comp
\ -------------------------
\ module slection de fonte
\ -------------------------

>fom FSinit,FStitle,FSopen

: MOD_FSEL
   17 >include "D:\PARX.SYS\FORTH\FONTSEL.FOM"
;

MOD_FSEL r ! 1 r modload drop

>comp

\ -------------
\ Outils utiles
\ -------------

: assign_string swap 24 w* + 12 + over over @ swap gets ! ;
: assign_fstring swap 24 w* + 12 + @ over over @ swap gets ! ;
: get_obstate swap 24 w* + 11 + c@ ;
: set_obstate swap 24 w* + 11 + c! ;
: update_win >r 3 0 0 0 0 r> 4 + get_xywh form_dial ;
: do_alert 5 swap rsrc_gaddr addrout @ form_alert ;

>comp

\ -------------
\  Dfinitions
\ -------------

0 0 rsrc_gaddr addrout @ dup constant tree_SAVERTF &wdial_create win_SAVERTF

screen_info highw       \ si moins de 16 couleurs
4 < if
   1 -1 tree_SAVERTF rsrc_mono  \ adapter au monochrome
then

16 allot constant BUF
14 allot constant OUT
variable exit_flag

variable choix          \ 1,2,3,4 selon le radio bouton
35 string family        \ famille de fontes PC
3 array Font_order      \ les indexs pour vqt_name
3 array Font_id         \ les identificateurs internes
35 3 array$ Font_name   \ les noms
256 string File_cfg
variable id             \ pour la slection des fontes
variable fonts          \ combien de fontes charges
256 string FORpath      \ chemin pour le fichier FOR
256 string RTFpath      \ pour le RTF
256 string chemin       \ temporaire
12 string FORname       \ idem pour les noms
12 string RTFname
12 string fichier
variable FORadr         \ adresse mmoire du fichier FOR
5 string TABlen         \ taille tabulation (5 chiffres)

>comp
vq_gdos
-2 <> if
   vst_load_fonts
   intout w@ fonts !
else
   0 fonts !
then

>comp
TABlen  TAB      tree_SAVERTF assign_fstring
FORname FILENAME tree_SAVERTF assign_fstring
family  FAMILY   tree_SAVERTF assign_fstring
FITALIC FBOLD FNORMAL
3 0 do
   i Font_name swap tree_SAVERTF assign_fstring
loop

: init
   1024 0 CFGset
   \ Sous l'interprteur, fichier fixe
   13 >ifflag
      " F:\SAVERTF.CFG" File_cfg $!
      File_cfg CFGload
      0= if
         CFGcreate drop
      then
   >endf

   \ en version compile, fichier dans le dossier
   -13 >ifflag
      " SAVERTF.CFG" File_cfg $!
      File_cfg shel_find
      intout w@ if
         File_cfg CFGload drop
      else
         " SAVERTF.PRG" File_cfg $!
         File_cfg shel_find
         intout w@ if
            " SAVERTF.CFG" File_cfg getpath $+ pad File_cfg $!
         then
         CFGcreate drop
      then
   >endf

   " TAB" CFGgetkey
   0= if " 720" then
   TABlen $!

   " FAMILY" CFGgetkey
   0= if " " then
   family $!

   " IDi" " IDb" " IDn"
   3 0 do
      CFGgetkey 0= if " 1" then
      val i Font_id !
   loop

   " NAMEi" " NAMEb" " NAMEn"
   3 0 do
      CFGgetkey 0= if " System" then
      i Font_name $!
   loop

   " CHOIX" CFGgetkey
   0= if " 3" then
   val choix !

   CHOIX choix @ + tree_SAVERTF get_obstate
   1 or
   CHOIX choix @ + tree_SAVERTF set_obstate

   3 0 do 0 i Font_order ! loop

   " FORPATH" CFGgetkey
   0= if " \*.FOR" then
   FORpath $!

   " RTFPATH" CFGgetkey
   0= if " \*.RTF" then
   RTFpath $!

   " " FORname $!
   remember
   0 FORadr !

;

   \ i select_font (0,1,2 pour normal, bold, italic)
: select_font
   id !
   fonts @ 0 FSinit
   0= if
      1 GDOS do_alert
   else
      id @ case
         0 of " Select Normal Font" endof
         1 of " Select Bold font for Forth words" endof
         drop " Select Italic font for comments"
      endcase
      FStitle drop
      id @ Font_order @ FSopen
      ?dup if
         dup id @ Font_order !
         vqt_name
         intout w@ id @ Font_id !
         id @ Font_name $!
         win_SAVERTF update_win
      then
   then
;

\ path file select_file
: select_file
   over over
   fichier $!
   chemin $!
   chemin fichier fsel_input
   intout w@ intout 2+ w@ w*
   if
      fichier swap $!
      chemin swap $!
      1
   else
      drop drop
      0
   then
;

\ -------------
\ dial SAVERTF
\ -------------

: do_FNORMAL
   0 select_font
;

: do_FBOLD
   1 select_font
;

: do_FITALIC
   2 select_font
;

: do_FILENAME
   FORpath FORname select_file
   if
      FORadr @ if    \ si ancien fichier charg
         restore     \ on vide la mmoire
      then
      2 graf_mouse
      0 -1 FORpath FORname path here loadbin
      0 graf_mouse
      dup
      0> if          \ si Ok
         remember          \ mmorise l'tat de la mmoire
         here FORadr !     \ adresse fichier
         top +!            \ +taille = adresse fin
         0 here !          \ annule les derniers octets
      else
         " " FORname $!    \ si erreur, pas de nom
         0 FORadr !        \ pas d'adresse
         abs 31 - form_error
      then
      win_SAVERTF update_win
   then
;

: do_SAVEOPT
   1 OVERWRIT do_alert
   intout w@ 1 = if
      2 graf_mouse
      \ d'abord mettre  jour le fichier config

      family len  \ si chaine vide, on enlve la cl
      if
         " FAMILY" family CFGsetkey drop
      else
         " FAMILY" CFGdelkey drop
      then

      TABlen len  \ si chaine vide, on enlve la cl
      if
         " TAB" TABlen CFGsetkey drop
      else
         " TAB" CFGdelkey drop
      then

      " CHOIX" CHOIX tree_SAVERTF getradio 2- str$ CFGsetkey drop

      " IDi" " IDb" " IDn"
      3 0 do
         i Font_id @ str$ CFGsetkey drop
      loop

      " NAMEi" " NAMEb" " NAMEn"
      3 0 do
         i Font_name CFGsetkey drop
      loop

      " FORPATH" FORpath CFGsetkey drop
      " RTFPATH" RTFpath CFGsetkey drop

      \ puis on sauve le fichier
      File_cfg CFGsave
      0 graf_mouse
      if
         1 SAVEOK
      else
         1 SAVEBUG
      then
      do_alert
   then
;

: do_SAVE
   FORadr @                \ un fichier charg?
   if
      TABlen len if        \ si une valeur prsente
         TABlen val RTFtab drop  \ dfinir la tabulation
      then
      RTFpath RTFname select_file
      if
         2 graf_mouse
         CHOIX tree_SAVERTF getradio 2-
         case
         1 of              \ mode PC, dfaut
            1 RTFmode drop
            0 RTFfont drop
            endof
         2 of              \ mode PC avec famille de fontes
            1 RTFmode drop
            family RTFfont drop
            endof
         3 of              \ Mode Atari dfaut
            0 RTFmode drop
            0 RTFfont drop
            endof
         drop              \ mode Atari avec 3 fonts
            0 RTFmode drop
            3 0 do
               i Font_name i Font_id @ i 1+ RTFfont drop
            loop
         endcase
         p @ 8 + @ sndb !     \ ".RTF" valeur magique
         FORadr @ sndb 4 + !  \ et adresse du fichier
         RTFpath RTFname path RTFsave
         0 graf_mouse
         if
            1 SAVEOK
         else
            1 SAVEBUG
         then
         do_alert
      then
   else
      1 NOFOR do_alert     \ signale si aucun fichier charg
   then
;

: do_QUIT
   1 ASKQUIT do_alert
   intout w@
   1 = if
      1 exit_flag !
   then
;

: do_SAVERTF
   case
      -1 of win_SAVERTF wdial_close endof
      FNORMAL of do_FNORMAL
         FNORMAL win_SAVERTF wdial_change endof
      FBOLD of do_FBOLD
         FBOLD win_SAVERTF wdial_change endof
      FITALIC of do_FITALIC
         FITALIC win_SAVERTF wdial_change endof
      FILENAME of do_FILENAME
         FILENAME win_SAVERTF wdial_change endof
      SAVEOPT of do_SAVEOPT
         SAVEOPT win_SAVERTF wdial_change endof
      SAVE of do_SAVE
         SAVE win_SAVERTF wdial_change endof
      QUIT of do_QUIT
         QUIT win_SAVERTF wdial_change endof
      drop
   endcase
;


>comp

\ -------------
\ Prg principal
\ -------------

: main

   init
   FAMILY " FORTH modules example" win_SAVERTF wdial_open drop

   0 exit_flag !
   begin
      BUF OUT wdial_evnt
      begin
         BUF OUT wdial_formdo
      while
         case
            win_SAVERTF of do_SAVERTF endof
         drop
         endcase
      repeat
   exit_flag @
   until
   win_SAVERTF wdial_close
   rsrc_free
;

>comp

   \ sous le compilateur, lancer le programme!

-13 >ifflag
   0 v_show_c
   main
>endf

\ -------------
\ Structure RSC
\ -------------

\ dial  SAVERTF -> do_SAVERTF tree_SAVERTF win_SAVERTF
\    IBox  CHOIX (Radio,Selct)
\    FBTxt FAMILY (Edit )
\    BText FNORMAL (Exit ,Selct) -> do_FNORMAL
\    BText FBOLD (Exit ,Selct) -> do_FBOLD
\    BText FITALIC (Exit ,Selct) -> do_FITALIC
\    FBTxt FILENAME (Edit ,Exit ,Selct) -> do_FILENAME
\    BText SAVEOPT (Exit ,Selct) -> do_SAVEOPT
\    Buttn SAVE (Exit ,Deflt,Selct) -> do_SAVE
\    Buttn QUIT (Exit ,Selct) -> do_QUIT
\    FBtxt TAB (Edit)
\ alrt  GDOS
\ alrt  SAVEOK
\ alrt  SAVEBUG
\ alrt  OVERWRIT
\ alrt  ASKQUIT
\ alrt  NOFOR
