$m65536,S>
'
title$="FontList 1.11"
'
' FontList  (Coded for Highwire Delelopment Project)
' =======================================================
' Lonny Pursell  - Font scanning routines
' Joakim H”gberg - GEM scrolling routines
'
INLINE findpart%,66
@init
@init_vdi
@init_menu
@init_popup
@main
'
> PROCEDURE main
  ap_id&=APPL_INIT()
  IF ap_id&<>-1
    m_task&=WORD{LONG{GB+4}+2}
    IF m_task&<>1
      ~@menu_register(ap_id&,"  "+title$+" ")
    ENDIF
    REPEAT
      filebuf%=@scan_fonts(gembsize%,fwpt%,files&,greyed_out&)
      last_row&=files&
      IF filebuf%>0           ! Got the font bufferok?
        col_total&=54         ! Hard code max number of allowed COLs
        col_max&=col_total&   ! Set current number of COLs to max
        @gem_scroller(1,40,20)
        dummy&=1
      ENDIF
    UNTIL dummy&=1
  ENDIF
  @vst_unload_fonts
  ~APPL_EXIT()
RETURN
> PROCEDURE init
  gembsize%=8192                        ! initial buffersize for font text
  entrybuf%=MALLOC(256)                 ! tmp entry buffer used when drawing
  mxmask%=@mxmask                       ! Check how to use mxalloc later on..
  homedir$=CHR$(ADD(GEMDOS(25),65))+":"+DIR$(0)+"\"  ! Find apps home dir
  ~SCRP_READ(clip_path$)                ! Find clipboard dir
  enabled&=128                          ! Status byte indicating enabled entry
  disabled&=128+8                       ! Status byte indicating disabled entry
  DIM q_ras%(7),z_ras%(7),par%(8)       ! Setup arrays for blitting
  '
  mes_adr%=@mxalloc_global(16,3)        ! alloc message buffer
  adress%=@mxalloc_global(128,3)        ! alloc window title buffer
  CHAR{adress%}=" "+title$+" "          ! set the window title
  '
  ABSOLUTE word0&,mes_adr%
  ABSOLUTE handle&,mes_adr%+6
  ABSOLUTE x&,mes_adr%+8
  ABSOLUTE y&,mes_adr%+10
  ABSOLUTE b&,mes_adr%+12
  ABSOLUTE h&,mes_adr%+14
  IF NOT EXIST(homedir$+"highwire.cfg")
    ALERT 3,"No config found!|Creating new file|with default values",1,"ok",dummy&
    @create_cfg
  ENDIF
RETURN
> PROCEDURE init_vdi
  ~GRAF_HANDLE(ch_w&,ch_h&,dummy&,dummy&)
  CONTRL(0)=39
  CONTRL(1)=0
  CONTRL(3)=2
  CONTRL(6)=V~H
  INTIN(0)=0
  INTIN(1)=5
  VDISYS
  ~WIND_GET(0,4,deskx&,desky&,xres&,yres&)
RETURN
> PROCEDURE init_popup
  DIM popup$(13)
  popup$(0)=" Normal (regular)       "
  popup$(1)=" Normal (bold)          "
  popup$(2)=" Normal (italic)        "
  popup$(3)=" Normal (bold/italic)   "
  popup$(4)="------------------------"
  popup$(5)=" Header (regular)       "
  popup$(6)=" Header (bold)          "
  popup$(7)=" Header (italic)        "
  popup$(8)=" Header (bold/italic)   "
  popup$(9)="------------------------"
  popup$(10)=" Teletype (regular)     "
  popup$(11)=" Teletype (bold)        "
  popup$(12)=" Teletype (italic)      "
  popup$(13)=" Teletype (bold/italic) "
  menu1%=MALLOC(24)                     ! Allocate struct buffers (in/out)
  menu2%=menu1%+12                      ! (second buffer half is for "out")
  IF menu1%<1
    @out_of_mem
    SYSTEM
  ENDIF
RETURN
> PROCEDURE init_menu
  DIM menu$(32)
  menu$(0)="FontList"
  menu$(1)="  About.."
  menu$(2)="---------------------"
  menu$(3)=" "
  menu$(4)=" "
  menu$(5)=" "
  menu$(6)=" "
  menu$(7)=" "
  menu$(8)=" "
  menu$(9)=""
  menu$(10)="File"
  menu$(11)="  Allow non-speedo "
  menu$(12)="  Quit        ^Q   "
  menu$(13)=""
  menu$(14)="Normal"
  menu$(15)=" Regular          "
  menu$(16)=" Bold             "
  menu$(17)=" Italic           "
  menu$(18)=" Bold/Italic      "
  menu$(19)=""
  menu$(20)="Header"
  menu$(21)=" Regular          "
  menu$(22)=" Bold             "
  menu$(23)=" Italic           "
  menu$(24)=" Bold/Italic      "
  menu$(25)=""
  menu$(26)="Teletype"
  menu$(27)=" Regular          "
  menu$(28)=" Bold             "
  menu$(29)=" Italic           "
  menu$(30)=" Bold/Italic      "
  menu$(31)=""
  menu$(32)=""
RETURN
> PROCEDURE menu(VAR menubar$())  ! Workaround for the GFA command MENU
  LOCAL menu%
  ' -- fix to adjust menu bar to work with naes menu hide option --
  MENU menubar$()                                        ! Create the menu
  menu%=MENU(-1)                                         ! Retrieve tree pointer
  OB_Y(menu%,OB_NEXT(menu%,1))=SUCC(OB_H(menu%,1))       ! Tweak 1
  OB_Y(menu%,SUCC(OB_TAIL(menu%,2)))=SUCC(OB_H(menu%,1)) ! Tweak 2
  ~MENU_BAR(menu%,1)                                     ! Update tree
RETURN
> FUNCTION menu_register(id&,t$)
$F%
LOCAL sa%
INLINE sa%,32
CHAR{sa%}=MID$(t$,1,30)+CHR$(0)
GCONTRL(0)=35
GINTIN(0)=id&
GCONTRL(1)=1
GCONTRL(2)=1
GCONTRL(3)=1
GCONTRL(4)=0
ADDRIN(FALSE)=sa%
GEMSYS
RETURN GINTOUT(0)
ENDFUNC
> FUNCTION mxmask  ! <-- Called once during startup!
$F%
IF GEMDOS(68,L:-1,0)=-32
RETURN 0
ELSE IF GEMDOS(290,-1)=-32
RETURN 3
ELSE
RETURN -1
ENDIF
ENDFUNC
> FUNCTION mxalloc_global(amount%,mode&)  ! Reserve memory used by other apps
$F%
' Mode mask: (bits 0 to 1)
'
' 0 = ST-RAM only
' 1 = TT-RAM only
' 2 = EITHER, ST-RAM prefered
' 3 = EITHER, TT-RAM prefered
'
' mode& must be a value from 0 to 3 (corresponding to bits 0-1 per Compendium)
IF mxmask%<>0
mode&=OR(mode&,&X100000)
RETURN GEMDOS(68,L:amount%,mode& AND mxmask%)
ELSE
RETURN MALLOC(amount%)
ENDIF
ENDFUNC
> PROCEDURE info_alert
ALERT 3,title$+" by Lp/GokMasE|Coded for and donated to|the Highwire project",1,"Ok",dummy&
RETURN
> PROCEDURE out_of_mem
ALERT 3,"Problems when|allocating memory!",1,"Ok",dummy&
RETURN
'
' -- Routines for maintaining the GEM scroller --
> PROCEDURE eval_menu(x&)
MENU OFF
SELECT x&
CASE 23   ! About..
@info_alert
CASE 32   ! toggle acceptance of non-speedo fonts
IF all_fonts!=FALSE
ALERT 3,"WARNING! Currently Highwire|really *needs* speedo fonts|to render text properly!",1,"Risk it",dummy&
MENU 11,1  ! Add ticker
ELSE
MENU 11,0  ! Remove ticker
ENDIF
all_fonts!=NOT all_fonts!
@deselect
IF NOT pop_icon!
@redraw_window(hdl&,deskx&,desky&,xres&,yres&)
ENDIF
CASE 33   ! Quit
pop_end!=TRUE
CASE 35 ! regular
@change_fontsetting("NORMAL =",@find_selected_id$)
CASE 36 ! bold
@change_fontsetting("BOLD_NORMAL =",@find_selected_id$)
CASE 37 ! italic
@change_fontsetting("ITALIC_NORMAL =",@find_selected_id$)
CASE 38 ! bold/italic  NORMAL
@change_fontsetting("BOLD_ITALIC_NORMAL =",@find_selected_id$)
CASE 40 ! regular
@change_fontsetting("HEADER =",@find_selected_id$)
CASE 41 ! bold
@change_fontsetting("BOLD_HEADER =",@find_selected_id$)
CASE 42 ! italic
@change_fontsetting("ITALIC_HEADER =",@find_selected_id$)
CASE 43 ! bold/italic
@change_fontsetting("BOLD_ITALIC_HEADER =",@find_selected_id$)
CASE 45 ! regular
@change_fontsetting("TELETYPE =",@find_selected_id$)
CASE 46 ! bold
@change_fontsetting("BOLD_TELETYPE =",@find_selected_id$)
CASE 47 ! italic
@change_fontsetting("ITALIC_TELETYPE =",@find_selected_id$)
CASE 48 ! bold/italic
@change_fontsetting("BOLD_ITALIC_TELETYPE =",@find_selected_id$)
ENDSELECT
RETURN
> PROCEDURE eval_aes
SELECT word0&
CASE 22360 ! winshade on
winshade!=TRUE
CASE 22361 ! winshade off
winshade!=FALSE
CASE 10  ! Evaluate the menubar
@eval_menu(x&)
CASE 20  ! Redraw
@redraw_window(handle&,x&,y&,b&,h&)
CASE 21
~WIND_SET(hdl&,10,0,0,0,0)
~WIND_SET(hdl&,29,0,0,0,0)
CASE 22  ! Closer widget
pop_ret&=0
pop_end!=TRUE
CASE 24,26
~WIND_GET(dummy&,10,hdle&,dummy&,dummy&,dummy&)
IF hdle&=hdl&
IF word0&=24
  SELECT x&
  CASE 0,1
    @control_slider(2,x&=0)
  CASE 2,3
    @control_slider(1,x&=2)
  ENDSELECT
ELSE IF word0&=26
  @position_slider(SUCC(DIV(MUL(x&,row_f&),1000)))
ENDIF
ELSE
~WIND_SET(hdl&,10,0,0,0,0)
ENDIF
CASE 27
~WIND_CALC(1,pop_state&,x&,y&,b&,h&,win_x&,win_y&,win_b&,win_h&)
row_max&=MIN(INT(DIV(win_h&,ch_h&)),last_row&)
ypos2&=MIN(ypos&,SUCC(SUB(last_row&,row_max&)))
'
abs&=ABS(ypos&-ypos2&)
factor&=SUCC(2*(ypos&>ypos2&))
FOR cnt&=1 TO abs&
REPEAT
  ADD firstrow%,factor&
UNTIL BYTE{ADD(filebuf%,firstrow%)}=1
NEXT cnt&
ypos&=ypos2&
'
row_f&=SUB(last_row&,row_max&)
col_max&=MIN(col_total&,INT(DIV(win_b&,ch_w&)))
scrl_w&=MUL(col_max&,ch_w&)
scrl_h&=MUL(PRED(row_max&),ch_h&)
~WIND_SET(hdl&,16,@slider_height,0,0,0)
~WIND_SET(hdl&,9,@slider_ypos,0,0,0)
~WIND_CALC(0,pop_state&,dummy&,dummy&,scrl_w&,MUL(row_max&,ch_h&),dummy&,dummy&,b&,h&)
'
~WIND_GET(hdl&,5,dummy&,dummy&,oldw&,oldh&)
~WIND_SET(hdl&,5,x&,y&,b&,h&)
'
IF oldw&<b& OR oldh&<h&            ! If window is enlarged..
REPEAT
  evnt%=EVNT_MESAG(mes_adr%)     ! Ignore pending redraws..
UNTIL handle&=hdl&
@redraw_window(hdl&,deskx&,desky&,xres&,yres&) ! Instead redraw full area
ENDIF
CASE 28
~WIND_SET(hdl&,5,x&,y&,b&,h&)
IF NOT pop_icon!
~WIND_GET(hdl&,4,m1x&,m1y&,dummy&,dummy&)
ENDIF
CASE 33
~WIND_SET(hdl&,25,0,0,0,0)
CASE 34
~WIND_GET(hdl&,4,rx&,ry&,rb&,rh&)
~GRAF_SHRINKBOX(x&,y&,b&,h&,rx&,ry&,rb&,rh&)
~WIND_SET(hdl&,26,x&,y&,b&,h&)
pop_icon!=TRUE
CASE 35
~WIND_GET(hdl&,4,rx&,ry&,rb&,rh&)
~GRAF_GROWBOX(rx&,ry&,rb&,rh&,x&,y&,b&,h&)
~WIND_SET(hdl&,27,x&,y&,b&,h&)
pop_icon!=FALSE
CASE 50 ! AP_TERM
pop_ret&=0
pop_end!=TRUE
ENDSELECT
RETURN
> PROCEDURE eval_keyboard
IF shift& OR (NOT pop_icon!)
ascii|=BCLR(BYTE(key&),5)
scan|=BYTE(SHR(key&,8))
'  PRINT AT(2,2);ascii|;"  ";scan|;"     ";shift&;"  "
IF shift&=0     ! <--- No SHIFT or CTRL-buttons pressed!
SELECT ascii|
CASE 0
  SELECT scan|
  CASE 72,80
    @control_slider(1,scan|=72)
  ENDSELECT
CASE 27
  IF scan|=1
    pop_end!=TRUE
  ENDIF
CASE 95
  @delete_selection
ENDSELECT
ELSE IF shift&=4
SELECT scan|
CASE 16
  pop_end!=TRUE
CASE 23             ! ctrl+I
  @info_alert
CASE 30             ! ctrl+a
  IF all!=FALSE
    cnt%=1
    FOR cnt&=1 TO last_row&
      length&=C:findpart%(L:filebuf%+cnt%,L:entrybuf%,0,1)
      IF BTST(BYTE{filebuf%+cnt%},0)=0  ! not selected?
        IF BTST(BYTE{filebuf%+cnt%},3)=0 OR all_fonts!
          INC pop_ret&
          BYTE{filebuf%+cnt%}=BSET(BYTE{filebuf%+cnt%},0)
        ENDIF
      ENDIF
      ADD cnt%,length&
    NEXT cnt&
    all!=TRUE
  ELSE
    cnt%=1
    FOR cnt&=1 TO last_row&
      length&=C:findpart%(L:filebuf%+cnt%,L:entrybuf%,0,1)
      BYTE{filebuf%+cnt%}=BCLR(BYTE{filebuf%+cnt%},0) ! unselect!
      ADD cnt%,length&
    NEXT cnt&
    pop_ret&=0
    all!=FALSE
  ENDIF
  @redraw_window(hdl&,deskx&,desky&,xres&,yres&)
CASE 46
  @send_to_clipboard
CASE 72,80
  @control_slider(2,scan|=72)
ENDSELECT
ENDIF
ENDIF
RETURN
> PROCEDURE eval_button
IF NOT pop_icon!
~WIND_GET(hdl&,4,rx&,ry&,rb&,rh&)
IF RC_INTERSECT(mx&,my&,1,1,rx&,ry&,rb&,rh&)
y_place&=MAX(0,MIN(PRED(row_max&),DIV(SUB(my&,m1y&),ch_h&)))
row&=ADD(m1y&,MUL(ch_h&,y_place&))
'
tempy%=1
FOR cnt&=1 TO y_place&
  length&=C:findpart%(L:filebuf%+firstrow%+tempy%,L:entrybuf%,0,1)
  ADD tempy%,length&
NEXT cnt&
'
IF numclicks&=2
  IF (NOT BTST(BYTE{filebuf%+firstrow%+tempy%},3)) OR all_fonts! ! not disabled?
    @deselect
    INC pop_ret&
    BYTE{filebuf%+firstrow%+tempy%}=BSET(BYTE{filebuf%+firstrow%+tempy%},0)
    @select_scrpop
  ENDIF
ELSE
  IF old_entry&<>y_place&+ypos&
    IF shift&=0
      @deselect
    ENDIF
    IF (NOT BTST(BYTE{filebuf%+firstrow%+tempy%},3)) OR all_fonts! ! not disabled?
      IF EVEN(BYTE{filebuf%+firstrow%+tempy%})
        BYTE{filebuf%+firstrow%+tempy%}=BSET(BYTE{filebuf%+firstrow%+tempy%},0)
        INC pop_ret&
      ELSE
        BYTE{filebuf%+firstrow%+tempy%}=BCLR(BYTE{filebuf%+firstrow%+tempy%},0)
        DEC pop_ret&
      ENDIF
      ~GRAF_MOUSE(256,0)
      @rsc_bitblt(12,m1x&,row&,scrl_w&,ch_h&,m1x&,row&)
      ~GRAF_MOUSE(257,0)
      old_entry&=ADD(y_place&,ypos&)
    ENDIF
  ENDIF
  IF mk&=2 AND pop_ret&=1                   ! Call for popup menu?
    popup%=@generate_popup(14,popup$())     ! Create the tree
    IF popup%>0
      CHAR{menu1%}=STRING$(23,0)            ! Zero struct buffer
      LONG{menu1%}=popup%                   ! Set tree pointer
      ' ~GRAF_MKSTATE(mx&,my&,mk&,dummy&)
      error&=@menu_popup(menu1%,mx&,my&,menu2%)  ! Entry clicked?
      IF error&>0
        @eval_menu(INT{menu2%+6}+34)        ! Pass to eval_menu
      ENDIF
      ~MFREE(popup%)                        ! Free popup buffer
    ENDIF
  ENDIF
ENDIF
ENDIF
all!=(pop_ret&=last_row&-greyed_out&)
ENDIF
RETURN
'
> PROCEDURE init_scroller
firstrow%=0
row_max&=MIN(row_max&,last_row&)
row_f&=SUB(last_row&,row_max&)
'
ypos&=1
'
scrl_w&=MUL(col_max&,ch_w&)
scrl_h&=MUL(PRED(row_max&),ch_h&)
RETURN
> PROCEDURE gem_scroller(m1x&,m1y&,row_max&)
LOCAL flag&,hdle&,cnt%,popup%,error&
~GRAF_MOUSE(0,0)
@menu(menu$())                    ! create and show menubar
'
@init_scroller
pop_state&=&X100000111101011                         ! window attributes
~WIND_CALC(0,pop_state&,0,0,col_total&*ch_w&,last_row&*ch_h&,win_x&,win_y&,win_b&,win_h&)
m1x&=DIV(xres&-scrl_w&,2)                            ! center txt area x-wise
m1y&=DIV(desky&+yres&-win_y&-MUL(row_max&,ch_h&),2)  ! center txt area y-wise
'
REPEAT
@init_scroller
hdl&=WIND_CREATE(pop_state&,0,0,win_b&,win_h&)          ! create window
~WIND_SET(hdl&,2,CARD(SWAP(adress%)),CARD(adress%),0,0) ! Set WTITLE
~WIND_SET(hdl&,16,@slider_height,0,0,0)                 ! Adjust slider
~WIND_CALC(0,pop_state&,m1x&,m1y&,col_max&*ch_w&,MUL(row_max&,ch_h&),win_x&,win_y&,win_b&,win_h&)
~WIND_OPEN(hdl&,win_x&,win_y&,win_b&,win_h&)            ! Open window
deleted!=FALSE
pop_end!=FALSE
'
flag&=&X10011
REPEAT
evnt%=EVNT_MULTI(flag&,258,3,0,0,0,0,0,0,0,0,0,0,0,mes_adr%,0,mx&,my&,mk&,shift&,key&,numclicks&)
IF BTST(evnt%,4)
  @eval_aes
ELSE IF BTST(evnt%,0)
  @eval_keyboard
ELSE IF BTST(evnt%,1)
  @eval_button
ENDIF
~GRAF_MKSTATE(dummy&,dummy&,mk&,dummy&)
IF mk&=0
  old_entry&=-1
ENDIF
UNTIL pop_end!
~WIND_CLOSE(hdl&)
~WIND_DELETE(hdl&)
UNTIL deleted!=FALSE
RETURN
> PROCEDURE redraw_window(handle&,x&,y&,b&,h&)
LOCAL count&,cnt%,tempx&,tempy&
~WIND_UPDATE(1)
~WIND_GET(handle&,11,rx&,ry&,rb&,rh&)
REPEAT
IF RC_INTERSECT(x&,y&,b&,h&,rx&,ry&,rb&,rh&)
~GRAF_MOUSE(256,0)
CLIP rx&,ry&,rb&,rh&
IF pop_icon!
  PBOX rx&,ry&,PRED(rb&+rx&),PRED(rh&+ry&)
  GRAPHMODE 2
  DEFTEXT 0,0,0,12,1
  ~WIND_GET(handle&,4,tempx&,tempy&,dummy&,dummy&)
  TEXT tempx&,tempy&,"FontList"
  TEXT tempx&,tempy&+ch_h&,"by Lp/Gok"
ELSE
  cnt%=SUCC(filebuf%+firstrow%)
  FOR count&=0 TO PRED(row_max&)
    ADD cnt%,C:findpart%(L:cnt%,L:entrybuf%,0,1)
    ' ---- draw text to screen -----
    tempy&=m1y&+count&*ch_h&
    IF (NOT BTST(BYTE{entrybuf%},3)) OR all_fonts!  ! is this entry enabled? (or allowed)
      DEFTEXT 1,0,0,13,1  ! black,normal,angle=0,13=std
    ELSE
      DEFTEXT 1,2,0,13,1  ! black,disabled,etc..
    ENDIF
    GRAPHMODE 1 ! replace
    TEXT m1x&,tempy&,LEFT$(CHAR{SUCC(entrybuf%)}+SPACE$(126),col_max&) ! Skip status byte
    IF ODD(BYTE{entrybuf%})                                 ! bit0 indicates a selected entry
      @rsc_bitblt(12,m1x&,tempy&,scrl_w&,ch_h&,m1x&,tempy&) ! invert it
    ENDIF
    ' ------------------------------
  NEXT count&
ENDIF
CLIP OFF
~GRAF_MOUSE(257,0)
ENDIF
~WIND_GET(handle&,12,rx&,ry&,rb&,rh&)
UNTIL rb&=0 AND rh&=0
~WIND_UPDATE(0)
RETURN
> PROCEDURE rsc_bitblt(mode&,ax&,ay&,ab&,ah&,gx&,gy&)
IF ab&>0 AND ah&>0
par%(0)=ax&                   ! X1-source
par%(1)=ay&                   ! Y1-source
par%(2)=ADD(ax&,PRED(ab&))    ! X2-source
par%(3)=ADD(ay&,PRED(ah&))    ! Y2-source
par%(4)=gx&                   ! X1-destination
par%(5)=gy&                   ! Y1-destination
par%(6)=ADD(gx&,PRED(ab&))    ! X2-destination
par%(7)=ADD(gy&,PRED(ah&))    ! Y2-destination
par%(8)=mode&                 ! Blitmode
BITBLT q_ras%(),z_ras%(),par%()
ENDIF
RETURN
> PROCEDURE select_scrpop
IF row&>0
FOR count&=0 TO 2
~GRAF_MOUSE(256,0)
@rsc_bitblt(12,m1x&,row&,scrl_w&,ch_h&,m1x&,row&)
~GRAF_MOUSE(257,0)
~EVNT_TIMER(50)
NEXT count&
ENDIF
'  ~C:findpart%(L:filebuf%+firstrow%,L:entrybuf%,SUCC(y_place&),1)
RETURN
> PROCEDURE deselect
LOCAL cnt%,length&
IF pop_ret&>0
cnt%=SUCC(filebuf%)
REPEAT
length&=C:findpart%(L:cnt%,L:entrybuf%,0,1)
IF BTST(BYTE{cnt%},0)  ! selected?
  DEC pop_ret&
  BYTE{cnt%}=BCLR(BYTE{cnt%},0)
ENDIF
ADD cnt%,length&
UNTIL pop_ret&=0
all!=FALSE
@redraw_window(hdl&,deskx&,desky&,xres&,yres&)
ENDIF
RETURN
> PROCEDURE send_to_clipboard
' This routine sends all selected entries (the text) to scrap.txt
LOCAL cnt%,count&,length&
OPEN "o",#1,clip_path$+"scrap.txt"
cnt%=SUCC(filebuf%)
REPEAT
INC count&
length&=C:findpart%(L:cnt%,L:entrybuf%,0,1)
IF BTST(BYTE{cnt%},0)  ! selected?
PRINT #1,CHAR{SUCC(entrybuf%)}
ENDIF
ADD cnt%,length&
UNTIL count&=last_row&
CLOSE #1
RETURN
> PROCEDURE delete_selection
LOCAL cnt%,length&
' Ok, this part is not really that relevant in font scan prg
' (previously used to delete search entries)
'
ALERT 3,"Really remove entries?",2,"Yes|No",dummy&
IF dummy&=1
cnt%=SUCC(filebuf%)
REPEAT
length&=C:findpart%(L:cnt%,L:entrybuf%,0,1)
IF BTST(BYTE{cnt%},0)  ! selected?
  DEC pop_ret&
  DEC last_row&
  SUB fwpt%,length&
  BMOVE ADD(cnt%,length&),cnt%,fwpt%
ELSE
  ADD cnt%,length&
ENDIF
UNTIL pop_ret&=0
pop_end!=TRUE
'
IF last_row&>0 ! Should we quit or continue?
deleted!=TRUE
ENDIF
ENDIF
RETURN
'
> FUNCTION menu_popup(menu%,xpos&,ypos&,mdata%)
$F%
GCONTRL(0)=36
GCONTRL(1)=2
GCONTRL(2)=1
GCONTRL(3)=2
GCONTRL(4)=0
GINTIN(0)=xpos&
GINTIN(1)=ypos&
ADDRIN(0)=menu%
ADDRIN(1)=mdata%
GEMSYS
RETURN GINTOUT(0)
' {
' OBJECT *mn_tree;
' WORD  mn_menu;
' WORD  mn_item;
' WORD  mn_scroll;
' WORD  mn_keystate;
' } MENU;
' The MENU structure members are defined as follows:
' Member         Meaning
' mn_tree        Points to the OBJECT tree of the sub-menu.
' mn_menu        Is an index to the parent object of the menu items.
' mn_item        Is the starting menu item.
' mn_scroll      If SCROLL_NO (0), the menu will not scroll.
'                If SCROLL_YES (1), and the number of menu
'                items exceed the menu scroll height, arrows
'                will appear which allow the user to scroll selections.
' mn_keystate    This member is unused and should be 0 for this call.
ENDFUNC
> FUNCTION generate_popup(items&,VAR entries$())
$F%
LOCAL buffaddr%,bufsize&,framesize&,root_width&,maxlength&,textbuffer%
framesize&=-1
maxlength&=LEN(entries$(0))
root_width&=maxlength&*ch_w&
'
bufsize&=SUCC(items&)*24+SUCC(maxlength&)*items&
buffaddr%=MALLOC(bufsize&)   ! buffer for all
IF buffaddr%>0
CHAR{buffaddr%}=STRING$(PRED(bufsize&),0)    ! zero buffer
textbuffer%=buffaddr%+SUCC(items&)*24        ! text begins at this address
' == create the tree ==
OB_NEXT(buffaddr%,0)=-1             ! Geneva will want this (or crash)
OB_HEAD(buffaddr%,0)=-1
OB_TAIL(buffaddr%,0)=-1
OB_TYPE(buffaddr%,0)=20             ! G_BOX
OB_STATE(buffaddr%,0)=0
OB_FLAGS(buffaddr%,0)=&X10000000000
IF framesize&<0
framesize&=SUCC(255 XOR ABS(framesize&))
ENDIF
OB_SPEC(buffaddr%,0)=&X1111100000000 OR SHL(framesize&,16)
OB_X(buffaddr%,0)=20
OB_Y(buffaddr%,0)=20
OB_W(buffaddr%,0)=root_width&
OB_H(buffaddr%,0)=items&*ch_h&
FOR i&=1 TO items&
CHAR{textbuffer%+PRED(i&)*SUCC(maxlength&)}=entries$(PRED(i&))
OB_NEXT(buffaddr%,i&)=-1
OB_HEAD(buffaddr%,i&)=-1
OB_TAIL(buffaddr%,i&)=-1
OB_TYPE(buffaddr%,i&)=28                     ! set the object type
OB_FLAGS(buffaddr%,i&)=0                     ! selected flag
OB_STATE(buffaddr%,i&)=8 AND BYTE{V:entries$(PRED(i&))}=45 ! disabled?
OB_X(buffaddr%,i&)=0
OB_Y(buffaddr%,i&)=PRED(i&)*ch_h&
OB_W(buffaddr%,i&)=root_width&
OB_H(buffaddr%,i&)=ch_h&
OB_SPEC(buffaddr%,i&)=textbuffer%+PRED(i&)*SUCC(maxlength&)
~OBJC_ADD(buffaddr%,0,i&)                    ! add object to tree
NEXT i&
OB_FLAGS(buffaddr%,items&)=&X100000            ! Set "last object"  flag
ELSE
@out_of_mem
ENDIF
RETURN buffaddr%                 ! return the buffer address of our tree
ENDFUNC
'
> PROCEDURE control_slider(type&,ydir&)
LOCAL ypos2&,step&
ydir&=SUCC(SHL(ydir&,1))       ! change from 0/-1 to -1/1
IF pop_icon!=FALSE AND winshade!=FALSE
IF type&=1                   ! Move 1 step
step&=1
ELSE IF type&=2              ! Page up/down
step&=row_max&
ENDIF
@position_slider(ADD(ypos&,step&*ydir&))
ENDIF
RETURN
> PROCEDURE position_slider(ypos2&)
LOCAL factor&,abs&
ypos2&=MAX(1,MIN(SUCC(last_row&-row_max&),ypos2&))
abs&=ABS(SUB(ypos&,ypos2&))
factor&=SUCC(SHL(ypos&>ypos2&,1))
FOR cnt&=1 TO abs&
REPEAT
ADD firstrow%,factor&
UNTIL BYTE{ADD(filebuf%,firstrow%)}=1
NEXT cnt&
ypos&=ypos2&
'
~WIND_UPDATE(1)
~GRAF_MOUSE(256,0)
@redraw_window(hdl&,deskx&,desky&,xres&,yres&)
~GRAF_MOUSE(257,0)
~WIND_UPDATE(0)
'
~WIND_SET(hdl&,9,@slider_ypos,0,0,0)
RETURN
> FUNCTION slider_height
$F%
RETURN 1000*row_max&/last_row&  ! Function for slider bar height
ENDFUNC
> FUNCTION slider_ypos
$F%
RETURN PRED(ypos&)*1000/MAX(1,row_f&) ! Function for slider bar y-position
ENDFUNC
'
'
' /////////////////////////////////////////////////////////////////////////////
' --  FONT STUFF -- (from FontList 1.0 although slightly stripped and adjusted)
'
> FUNCTION scan_fonts(textbufsize%,VAR fwpt%,files&,greyed_out&)
LOCAL f&,i&,o&,f$,dummy%,bt&,filebuf%,tmp% ! some temporary variables
nvdi_!=@cookie_get(FALSE,"NVDI",dummy%)    ! set a flag if nvdi is present
font_total&=@vst_load_fonts                ! load the fonts and save the total
IF font_total&>0
filebuf%=MALLOC(textbufsize%)             ! allocate buffer for font entries
IF filebuf%>0                             ! we got buffer ok?
BYTE{filebuf%}=1                        ! Start with chr$(1) (separator)
fwpt%=1                                 ! file write pointer increased with 1
FOR i&=0 TO PRED(font_total&)                      ! start font scan...
IF nvdi_!=FALSE                                  ! nvdi is not present?
f&=@vqt_name(SUCC(i&),f$,o&)                   ! standard vdi call
type&=ABS(NOT o&)                              ! bmp(false)->1,unknown(true) ->0
flag&=0                                        ! force flag to 0
all_fonts!=TRUE                                ! enable all fonts
ELSE                                             ! nvdi is present?
f&=@vqt_ext_name(SUCC(i&),f$,o&,type&,flag&)   ! nvdi extended call
ENDIF
bt&=disabled&
INC greyed_out&
SELECT type&
CASE 1
tpe$=" - Bitmapped"
CASE 2
bt&=enabled&                 ! First byte in entry (for status)
DEC greyed_out&              ! This entry is not regarded disabled
tpe$=" - Speedo"
CASE 4
tpe$=" - TrueType"
CASE 8
tpe$=" - Type 1"
DEFAULT
tpe$=" - ?"
ENDSELECT
IF fwpt%+128>gembsize% ! extend buffer?
ADD gembsize%,8192
tmp%=MALLOC(gembsize%)
IF tmp%>0
BMOVE filebuf%,tmp%,fwpt%
~MFREE(filebuf%)
SWAP filebuf%,tmp%
ELSE
@out_of_mem
SYSTEM       ! Couldn't extend buffer, we need to bail out!
ENDIF
ENDIF
entry$=f$+SPACE$(32-LEN(f$))+" - "+STR$(f&,5)+tpe$  ! output font name & id
BYTE{filebuf%+fwpt%}=bt&           ! First byte in entry (ena/dis)
CHAR{SUCC(filebuf%+fwpt%)}=entry$  ! Enter the font data in buffer
ADD fwpt%,ADD(LEN(entry$),2)       ! Update file write pointer
BYTE{PRED(filebuf%+fwpt%)}=1       ! Add ascii separator
INC files&                         ! Number of entries, +1
NEXT i&                              ! loop back for next font...
ELSE
@out_of_mem
ENDIF
ELSE
ALERT 3,"No fonts were found!",1,"Ok",dummy&
ENDIF
RETURN filebuf%                          ! return buffer to gem routine
ENDFUNC
'
' -- VDI bindings --
> FUNCTION vst_load_fonts !v0.04
$F%
LOCAL r&
IF GDOS?=TRUE
@vst_unload_fonts
CONTRL(0)=119
CONTRL(1)=0
CONTRL(3)=1
CONTRL(6)=V~H
INTIN(0)=0
VDISYS
r&=INTOUT(0)+WORK_OUT(10)
ELSE
r&=WORK_OUT(10)
ENDIF
RETURN r&
ENDFUNC
> PROCEDURE vst_unload_fonts !v0.04
IF GDOS?=TRUE
CONTRL(0)=120
CONTRL(1)=0
CONTRL(3)=1
CONTRL(6)=V~H
INTIN(0)=0
VDISYS
ENDIF
RETURN
> FUNCTION vqt_name(i&,VAR n$,o&) !v0.05
$F%
LOCAL a&,c&
CONTRL(0)=130
CONTRL(1)=0
CONTRL(3)=1
CONTRL(6)=V~H
INTIN(0)=i&
VDISYS
n$=""
FOR c&=1 TO 32
a&=INTOUT(c&)
EXIT IF a&=0
n$=n$+CHR$(a&)
NEXT c&
IF CONTRL(4)<=33 !assume bitmap font?
o&=0
ELSE !use font type info?
o&=ABS(INTOUT(33)<>0)
ENDIF
RETURN INTOUT(0)
ENDFUNC
> FUNCTION vqt_ext_name(i&,VAR n$,o&,t&,f&) !v0.01
$F%
LOCAL a&,c&
CONTRL(0)=130
CONTRL(1)=0
CONTRL(3)=2
CONTRL(5)=1
CONTRL(6)=V~H
INTIN(0)=i&
INTIN(1)=0
VDISYS
n$=""
FOR c&=1 TO 32
a&=INTOUT(c&)
EXIT IF a&=0
n$=n$+CHR$(a&)
NEXT c&
IF CONTRL(4)<=33 !assume bitmap font?
o&=0
ELSE !use font type info?
o&=ABS(INTOUT(33)<>0)
ENDIF
t&=BYTE(INTOUT(34))
f&=BYTE(SHR&(INTOUT(34),8))
RETURN INTOUT(0)
ENDFUNC
> FUNCTION cookie_get(u!,id$,VAR i%) !v0.04
$F%
LOCAL s!,a%,c$
CLR s!,i%
a%=LPEEK(&H5A0)
IF a%>0
IF u!=TRUE
id$=UPPER$(id$)
ENDIF
DO
c$=MKL$(LPEEK(a%))
IF u!=TRUE
c$=UPPER$(c$)
ENDIF
IF c$=id$
i%=LPEEK(a%+4)
s!=TRUE
EXIT IF TRUE
ENDIF
EXIT IF LPEEK(a%)=0
a%=ADD(a%,8)
LOOP
ENDIF
RETURN s!
ENDFUNC
' ////////////////////////////////////////////////////////////////////////////
'
'  Code to actually update the HW config
> PROCEDURE change_fontsetting(look_for$,set_entry$)
LOCAL inbuffer%,fname%,fhandle&,lof%,updated!
'  ALERT 3,look_for$+"|"+set_entry$,1,"ok",dummy&
IF pop_ret&=1
fname%=MALLOC(LEN(homedir$)+16)           ! allocate buffer for gemdos path
IF fname%>0                               ! we got buffer ok?
CHAR{fname%}=homedir$+"highwire.cfg"    ! stuff path into buffer
fhandle&=@fopen(fname%,0)               ! open Highwire config
IF fhandle&>-1                          ! file opened ok?
lof%=@fseek(0,fhandle&,2)             ! check lof
~@fseek(0,fhandle&,0)                 ! move read pointer to beginning
inbuffer%=MALLOC(lof%)                ! allocate buffer for the file
IF inbuffer%>0                        ! we got buffer ok?
~@fread(fhandle&,lof%,inbuffer%)    ! read the file!
OPEN "O",#2,homedir$+"highwire.cnx" ! create a work copy of hw config
'
cnt%=inbuffer%
REPEAT
length&=C:findpart%(L:cnt%,L:entrybuf%,0,13)
ADD cnt%,SUCC(length&)  ! Add 1 byte for <lf>
IF INSTR(LEFT$(CHAR{entrybuf%},LEN(look_for$)),look_for$)  ! look for string
PRINT #2,look_for$+" "+set_entry$           ! we found string, update
updated!=TRUE
ELSE
PRINT #2,CHAR{entrybuf%}          ! No match, copy line from old config "as is"
ENDIF
UNTIL (cnt%-inbuffer%)>=lof%          ! Reached end of file?
'
IF updated!=FALSE
PRINT #2,look_for$+" "+set_entry$
ENDIF
'
~@fclose(fhandle&)                  ! close file
CLOSE #2
'
KILL homedir$+"highwire.cfg"
NAME homedir$+"highwire.cnx" AS homedir$+"highwire.cfg"
~MFREE(inbuffer%)
ELSE
@out_of_mem
ENDIF
ELSE
ALERT 3,"Could not open|"+homedir$+"|highwire.cfg",1,"Ok",dummy&
ENDIF
~MFREE(fname%)
ELSE
@out_of_mem
ENDIF
ELSE
ALERT 3,"Have 1 font selected|when trying to update|highwire.cfg",1,"Duh!",dummy&
ENDIF
RETURN
> FUNCTION find_selected_id$
$F%
LOCAL cnt%,length&
IF pop_ret&>0
cnt%=SUCC(filebuf%)
REPEAT
ADD cnt%,length&
length&=C:findpart%(L:cnt%,L:entrybuf%,0,1)
UNTIL BTST(BYTE{cnt%},0)  ! selected?
ADD cnt%,35
~C:findpart%(L:cnt%,L:entrybuf%,0,45) ! 45 = "-"
'    PRINT AT(30,3);CHAR{entrybuf%};"<<  "
RETURN TRIM$(CHAR{entrybuf%})
ELSE
RETURN ""
ENDIF
ENDFUNC
> PROCEDURE create_cfg
OPEN "O",#1,homedir$+"highwire.cfg" ! create a default config
PRINT #1,"#"
PRINT #1,"# Configuration file for HighWire"
PRINT #1,"#"
PRINT #1,"# '#' are remark lines and ignored"
PRINT #1,"#"
PRINT #1,"# Variables are set in the following manner"
PRINT #1,"#"
PRINT #1,"# NORMAL = 184959"
PRINT #1,"#"
PRINT #1,"# Where the first part is the variable name"
PRINT #1,"# then a space, then an = and then another space"
PRINT #1,"# followed by the value you want it set to."
PRINT #1,"#"
PRINT #1,"#"
PRINT #1,"# Normal Font"
PRINT #1,"#"
PRINT #1,"# This is the font that the normal text will be"
PRINT #1,"# displayed with."
PRINT #1,"#"
PRINT #1,"# The value for ALL font variables is the index number"
PRINT #1,"#"
PRINT #1,"# There are 4 necessary values for each of the font"
PRINT #1,"# variables, these are plain, italic, bold, bold italic"
PRINT #1,"#"
PRINT #1,"NORMAL = 1"
PRINT #1,"ITALIC_NORMAL = 1"
PRINT #1,"BOLD_NORMAL = 1"
PRINT #1,"BOLD_ITALIC_NORMAL = 1"
PRINT #1,"# Header Font"
PRINT #1,"#"
PRINT #1,"# The font that headers will be displayed with"
PRINT #1,"HEADER = 1"
PRINT #1,"ITALIC_HEADER = 1"
PRINT #1,"BOLD_HEADER = 1"
PRINT #1,"BOLD_ITALIC_HEADER = 1"
PRINT #1,"# Teletype Font"
PRINT #1,"#"
PRINT #1,"# Font used for PRE and TT tags"
PRINT #1,"TELETYPE = 1"
PRINT #1,"ITALIC_TELETYPE = 1"
PRINT #1,"BOLD_TELETYPE = 1"
PRINT #1,"BOLD_ITALIC_TELETYPE = 1"
CLOSE #1
RETURN
'
' GEMDOS bindings
> FUNCTION fopen(fname%,mode&)
$F%
RETURN GEMDOS(&H3D,L:fname%,W:mode&)
ENDFUNC
> FUNCTION fclose(fhandle&)
$F%
RETURN GEMDOS(&H3E,W:fhandle&)
ENDFUNC
> FUNCTION fread(fhandle&,count%,buffer%)
$F%
RETURN GEMDOS(&H3F,W:fhandle&,L:count%,L:buffer%)
ENDFUNC
> FUNCTION fseek(offset%,fhandle&,seekmode&)
$F%
RETURN GEMDOS(&H42,L:offset%,fhandle&,seekmode&)
ENDFUNC
