Clarion: Create Tag Buttons

CreateTagButtons.clw

  PROGRAM

  MAP
  END

  INCLUDE(      'errors.clw'),ONCE
  INCLUDE(    'keyCodes.clw'),ONCE 
  INCLUDE('ctTagButtons.inc'),ONCE 
TagButtons ctTagButtons

UI:NewButtonText CSTRING(100)


Window WINDOW('Test Button Width'),AT(,,395,110),GRAY,AUTO,FONT('Segoe UI',16)
        STRING('NextX'),AT(7,94)
        STRING(@N5),AT(31,94),USE(TagButtons.NextX)
        STRING('NextY'),AT(87,94)
        STRING(@N5),AT(108,94),USE(TagButtons.NextY)
        PROMPT('Press enter to Create new button'),AT(5,6,66,17),USE(?PROMPT1)
        ENTRY(@s100),AT(77,6,309),USE(UI:NewButtonText),ALRT(EnterKey)
        BUTTON('&OK'),AT(237,94,,14),USE(?Ok),DEFAULT
        BUTTON('&Cancel'),AT(286,94,,14),USE(?Cancel),STD(STD:Close)
    END

  include('debuger.inc'),ONCE 
dbg        debuger

  CODE
  dbg.mg_init('CreateTagButtons')
  Open(Window)
  TagButtons.MaxX = 0{PROP:Width}

  ACCEPT
    dbg.PrintEvent('')
    CASE EVENT()
      OF EVENT:AlertKey  ; DO OnAlertKey
      OF EVENT:Accepted  ; DO OnAccepted
    END    
      
  END 

!---------------------------
OnAlertKey           ROUTINE 
 CASE FIELD() 
   OF ?UI:NewButtonText
      CASE KEYCODE() 
        OF EnterKey; DO CallTagButons_Create
      END 
 END 


!---------------------------
CallTagButons_Create ROUTINE         
 UPDATE()
 TagButtons.CreateButton(UI:NewButtonText)
          UI:NewButtonText = ''
 DISPLAY(?UI:NewButtonText)
 
!---------------------------
OnAccepted           ROUTINE   
  IF TagButtons.FEQs.FindID( ACCEPTED() ) = NoError
     TagButtons.RemoveButton()
  END 

ctQLong.clw

  MEMBER
  MAP
  END
  INCLUDE('ctQLong.inc'),ONCE

NoError EQUATE(0)

ctQLong.CONSTRUCT PROCEDURE
   CODE
   SELF.Q        &= NEW qtLong; CLEAR(SELF.Q)
   SELF.BaseQ &= SELF.Q


!===============================================
ctQLong.Add       PROCEDURE(LONG xNewValue)
   CODE
   SELF.Q.ID = xNewValue
   ADD(SELF.Q)

!===============================================
ctQLong.AddUnique PROCEDURE(LONG xNewValue)
RetAdded BOOL(FALSE)
   CODE
   IF SELF.FindID(xNewValue) ! <> NoError
      SELF.Add(xNewValue)
      RetAdded = TRUE
   END
   RETURN RetAdded

!===============================================
ctQLong.FindID    PROCEDURE(LONG xValue)
   CODE
   SELF.Q.ID = xValue
   GET(SELF.Q, SELF.Q.ID)
   RETURN ERRORCODE()


!===============================================
ctQLong.ToString  PROCEDURE()!,STRING,DERIVED
   CODE
   RETURN PARENT.ToString() & ' ID[' & SELF.Q.ID &']'

!===============================================
ctQLong.Del       PROCEDURE(LONG xValue   )!,BOOL,PROC !Returns TRUE when Deleted, FALSE when not found
FoundAndDeleted BOOL(FALSE)
   CODE 
   IF SELF.FindID( xValue ) = NoError
      SELF.Del()
      FoundAndDeleted = TRUE 
   END 
   RETURN FoundAndDeleted

ctQLong.inc

   ! https://github.com/MarkGoldberg/CwUnit/blob/master/Libsrc/ctQueue.inc
   INCLUDE('ctQueue.inc'),ONCE

qtLong QUEUE,TYPE
ID       LONG
       END

ctQLong CLASS(ctQueue),TYPE,MODULE('ctQLong.clw'),LINK('ctQLong.clw')
Q         &qtLong

CONSTRUCT PROCEDURE
Add       PROCEDURE(LONG xNewValue)
AddUnique PROCEDURE(LONG xNewValue),BOOL,PROC !Returns TRUE when added, FALSE when already existed
FindID    PROCEDURE(LONG xValue   ),LONG,PROC !Returns ErrorCode
Del       PROCEDURE(LONG xValue   ),BOOL,PROC !Returns TRUE when Deleted, FALSE when not found
ToString  PROCEDURE(),STRING,DERIVED
       END

ctTagButton.clw

  MEMBER 
  MAP 
  END 
  INCLUDE('ctTagButtons.inc'),ONCE

  INCLUDE('errors.clw'),ONCE
  
!===============================================
ctTagButtons.Construct               PROCEDURE()
  CODE 
  SELF.FEQs &= NEW ctQLong

  SELF.HorizSpacer  =  4
  SELF.VertSpacer   =  2
  SELF.ButtonHeight = 14
  SELF.InitialX     =  7
  SELF.InitialY     = 25
 
  SELF.NextX = SELF.InitialX 
  SELF.NextY = SELF.InitialY


!===============================================
ctTagButtons.Destruct               PROCEDURE()
  CODE 
  DISPOSE(SELF.FEQs)


!===============================================
ctTagButtons.RemoveButton            PROCEDURE() ! assumes SELF.FEQs is aligned
Ptr LONG,AUTO 
  CODE 
  Ptr        = SELF.FEQs.Pointer() - 1

  SELF.NextX = SELF.FEQs.Q.ID{PROP:XPOS}
  SELF.NextY = SELF.FEQs.Q.ID{PROP:YPOS} 
  DESTROY(     SELF.FEQs.Q.ID )
  SELF.FEQs.Del() 
  
  LOOP WHILE SELF.FEQs.GetNextRow(Ptr) = NoError 
     SELF.FEQs.Q.ID{PROP:XPOS} = SELF.NextX
     SELF.FEQs.Q.ID{PROP:YPOS} = SELF.NextY 

     SELF.WrapToNextRowAsNeeded()
     SELF.SetNextXY()
  END 

  IF SELF.FEQs.Count() = 0
     SELF.NextX = SELF.InitialX 
     SELF.NextY = SELF.InitialY
  END 

  

!===============================================
ctTagButtons.CreateButton            PROCEDURE(STRING xButtonText)  
NewButton   LONG,AUTO 
NoIconWidth LONG,AUTO
  CODE                                              
  NewButton = CREATE( 0, CREATE:Button )
  SELF.FEQs.ADD( NewButton )
  NewButton{PROP:Text}   = xButtonText
  NewButton{PROP:XPOS}   = SELF.NextX
  NewButton{PROP:YPOS}   = SELF.NextY 
  NewButton{PROP:Height} = SELF.ButtonHeight

  NoIconWidth = NewButton{PROP:Width}
  NewButton{PROP:Icon}   = ICON:Cross
  NewButton{PROP:Right}  = TRUE 
  NewButton{PROP:Width}  = NoIconWidth + 6  ! to avoid odd word wrapping (todo: tune the amount to add for the icon)
 
  SELF.WrapToNextRowAsNeeded()

  NewButton{PROP:Hide}   = FALSE 

  SELF.SetNextXY()

!===============================================
ctTagButtons.WrapToNextRowAsNeeded   PROCEDURE()  ! assumes SELF.FEQs is aligned
  CODE
  IF SELF.FEQs.Q.ID{PROP:Width} + SELF.NextX > SELF.MaxX
     SELF.FEQs.Q.ID{PROP:XPOS} = SELF.InitialX
     SELF.FEQs.Q.ID{PROP:YPOS} = SELF.NextY + SELF.FEQs.Q.ID{PROP:Height} + SELF.VertSpacer
  END   

!===============================================
ctTagButtons.SetNextXY               PROCEDURE() ! assumes ButtonsFEQs is alinged
  CODE 
  SELF.NextX = SELF.FEQs.Q.ID{PROP:XPOS} + SELF.FEQs.Q.ID{PROP:Width} + SELF.HorizSpacer 
  SELF.NextY = SELF.FEQs.Q.ID{PROP:YPOS}  

  IF SELF.NextX  > SELF.MaxX
     SELF.NextX  = SELF.InitialX
     SELF.NextY += SELF.ButtonHeight + SELF.VertSpacer  
  END 
  

ctTagButton.inc

  include('ctQLong.inc'),ONCE 

ctTagButtons CLASS,TYPE,MODULE('ctTagButtons.clw'),LINK('ctTagButtons.clw')
HorizSpacer  LONG 
VertSpacer   LONG 
ButtonHeight LONG 
InitialX     LONG 
InitialY     LONG 
MaxX         LONG

NextX        LONG
NextY        LONG 

FEQs                   &ctQLong
!---------------------
Construct               PROCEDURE() 
Destruct                PROCEDURE() 

RemoveButton            PROCEDURE() 
CreateButton            PROCEDURE(STRING xButtonText)  
SetNextXY               PROCEDURE() ! assume ButtonsFEQs is alinged
WrapToNextRowAsNeeded   PROCEDURE()
             END