Word Cloud

Category: Utilities

Date: 03-28-2012

Return to Index


 
'This utility creates a graphical image of all words in a text string,
'randomly placed but sized according to frequency.  It's similar to Word
'Clouds you see on the Internet.
 
'Compiler Comments:
'This code uses a resizable Graphic Control, so it will compile only in
'PBWin10. In PBWin9, the graphic control cannot be resized, so you have
'to KILL the control, then use Control Add Graphic to recreate the control
'at the new size.
 
'Primary Code:
'This utility works by parsing a text string for words, while counting
'each word's frequency. Words are then displayed randomly within a graphic
'control, but with font size proportaional to the word's frequency.
 
'The DrawCloud function (below) is the primary code of interest). My
'freeward application gbWordCloud provides a much greater feature set.
 
'Compilable Example:
#Compiler PBWin 10
#Compile EXE
#Dim All
#Debug Display On
#Debug Error On
#Include "Win32API.inc"
 
Type Cloud
   text As String * 20
   freq As Long    ' 0 to 100 %
   rgb As Long     'color    'reserved
   trans As Long   '0-100 %  'reserved
   rc As Rect
   fontSize As Long
   mark As Long
End Type
 
   %IDC_ButtonCreate = 500
   %IDC_ButtonShow   = 501
   %IDC_TextIn       = 502
   %IDC_Graphic      = 503
   %IDC_Statusbar    = 504
 
   Global hDlg,hGraphic As Dword, MaxFontSize, MinFontSize, MaxFreq, OldPos, OnWord, OffWord,BGColor As Long
   Global CWords() As Cloud, Words() As String, FontName As String, FontsA(), FontsB() As Dword
 
Function PBMain() As Long
   Local style&
   style& = %WS_TabStop Or %WS_Border Or  %ES_Left Or %ES_AutoHScroll Or %ES_AutoVScroll _
      Or %ES_MultiLine Or %ES_NoHideSel Or %ES_WantReturn
   Dialog New Pixels, 0, "Word Cloud",300,300,520,730, %WS_OverlappedWindow To hDlg
   Control Add Button, hDlg, %IDC_ButtonCreate,"Create", 10,10,80,20
   Control Add Button, hDlg, %IDC_ButtonShow,"Show List", 110,10,90,20
   Control Add TextBox, hDlg, %IDC_TextIn,"Paste the words." + $CrLf + "Press the create button." + $CrLf + "See the words cloud.", 10,40,500,150, Style&
   Control Add Graphic, hDlg, %IDC_Graphic, "", 10,200,500,500, %WS_Border
   Control Add Statusbar, hDlg, %IDC_StatusBar, "", 0,0,0,0
   Control Handle hDlg, %IDC_Graphic To hGraphic
   Graphic Attach hDlg, %IDC_Graphic, ReDraw
   Graphic Color -1, -2
   Graphic Clear BGColor, 0
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Local i,w,h As Long, pt,ptg,ptd As Point
   Select Case Cb.Msg
      Case %WM_InitDialog
         MinFontSize = 8
         MaxFontSize = 48
         FontName = "Arial"
         BGColor = %rgb_LightGray
         CreateFonts
         Randomize Timer
         oldPos = -1
 
      Case %WM_MouseMove
         GetCursorPos pt               'pt has xy screen coordinates
         ptd = pt : ptg = pt
         ScreenToClient hDlg, ptd       'pt now has dialog client coordinates
         ScreenToClient hGraphic, ptg       'pt now has dialog client coordinates
         If ChildWindowFromPoint(hDlg,ptd)=hGraphic Then
            For i = 0 To UBound(CWords)
               OnWord = 0
               If PtInRect(CWords(i).rc,ptg) Then
                  OnWord = 1
                  Statusbar Set Text hDlg, %IDC_Statusbar, 1, 0, Trim$(CWords(i).Text) + Str$(CWords(i).freq)
                  CWords(i).Mark = 1
                  If oldPos <> -1 Then ClearOld : CWords(oldPos).Mark = 0
                  DrawNew(i)
                  oldPos = i
                  Exit For
               End If
            Next i
         Else
            OnWord = 0
         End If
         If OnWord = 0 Then Statusbar Set Text hDlg, %IDC_Statusbar, 1, 0, ""
      Case %WM_Command
         Select Case Cb.Ctl
            Case %IDC_ButtonCreate : DrawCloud
            Case %IDC_ButtonShow   : DisplayResult
         End Select
      Case %WM_Size
         Dialog Get Client hDlg To w,h
         Graphic Set Size w-20,h-230
         Control Set Size hDlg, %IDC_TextIn, w-20,150
         ReDrawCloud
   End Select
End Function
 
Sub DisplayResult
   Local i As Long,result$
   Dim tempArray(UBound(Words())) As String
   For i = 0 To UBound(CWords)
      result$ = result$ + Format$(CWords(i).freq,"0000 ") + Trim$(CWords(i).Text) + "  " + Str$(CWords(i).FontSize)+ _
         Space$(5) + Str$(CWords(i).rc.nLeft) + Str$(CWords(i).rc.nRight) + Str$(CWords(i).rc.nTop) + Str$(CWords(i).rc.nBottom) + $CrLf
   Next i
   result$ = Trim$(result$,$CrLf)
   ReDim tempArray(ParseCount(result$, $CrLf)-1)
   Parse result$, tempArray(), $CrLf
   Array Sort tempArray()
   Open Exe.Path$ + "results.txtFor Output As #1
   Print #1, Join$(tempArray(),$CrLf) + $CrLf + "MaxFreq: " + Str$(MaxFreq)
   Close #1
   i = Shell ("notepad.exe " + Exe.Path$ + "results.txt", 1)  'does not wait for it to close
End Sub
 
Sub DrawCloud
   Local delimiter$,result$,temp$,i,j,w,h,iPos,gW,gH As Long
   MousePtr 11
 
   'get sorted list of all words
   Control Get Text hDlg, %IDC_TextIn To temp$
   delimiter$ = Chr$(0 To 64, 91 To 96, 123 To 127)   '<--- all non-letter
   temp$ = LCase$(Trim$(temp$, Any delimiter))
   ReDim Words(ParseCount(temp$, Any delimiter)-1), CWords(UBound(Words))
   Parse temp$, Words(), Any delimiter
   Array Sort Words()
 
   'create CWords() - word list and frequency
   CWords(iPos).Text = Words(0) : CWords(iPos).freq = 1 : MaxFreq = 1
   For i = 1 To UBound(Words)
      If Len(Trim$(Words(i))) = 0 Then Iterate For
      If Words(i) = Words(i-1) Then
         Incr CWords(iPos).freq
         MaxFreq = Max(MaxFreq,CWords(iPos).freq)
      Else
         Incr iPos
         CWords(iPos).Text = Words(i) : CWords(iPos).freq = 1
      End If
   Next i
   ReDim Preserve CWords(iPos)
 
   'set font sizes, position
   '    Graphic Color -1, -2
   Graphic Clear BGColor, 0
   Control Get Client hDlg, %IDC_Graphic To gW,gH
   For i = 0 To UBound(CWords)
      CWords(i).fontSize = (MaxFontSize-MinFontSize) * (CWords(i).Freq/MaxFreq) + MinFontSize
      Graphic Set Font FontsA(CWords(i).FontSize)
      Graphic Text Size Trim$(CWords(i).TextTo w,h
 
      CWords(i).rc.nLeft = Rnd(10,gW)
      CWords(i).rc.nTop = Rnd(10,gH)
      CWords(i).rc.nLeft = Min(CWords(i).rc.nLeft, gW-w-10)
      CWords(i).rc.nTop = Min(CWords(i).rc.nTop, gH-h-10)
      CWords(i).rc.nRight = CWords(i).rc.nLeft + w
      CWords(i).rc.nBottom = CWords(i).rc.nTop + h
 
      Graphic Set Pos (CWords(i).rc.nLeft,CWords(i).rc.nTop)
      Graphic Color GetColor(CWords(i).freq/MaxFreq), -2
      Graphic Print Trim$(CWords(i).Text)
   Next i
   Graphic ReDraw
 
   MousePtr 0
End Sub
 
Sub ClearOld
   If oldPos = -1 Then Exit Sub
   Graphic Color -1, -2
   Graphic Box (CWords(oldPos).rc.nLeft,CWords(oldPos).rc.nTop)-(CWords(oldPos).rc.nRight,CWords(oldPos).rc.nBottom),,BGColor,BGColor,0
   Graphic Set Font FontsA(CWords(oldPos).FontSize)
   Graphic Set Pos (CWords(oldPos).rc.nLeft,CWords(oldPos).rc.nTop)
   Graphic Color GetColor(CWords(oldPos).freq/MaxFreq), -2
   Graphic Print Trim$(CWords(oldPos).Text)
   Graphic ReDraw
End Sub
 
Sub DrawNew(iPos As Long)
   Graphic Color -1, -2
   Graphic Box (CWords(iPos).rc.nLeft,CWords(iPos).rc.nTop)-(CWords(iPos).rc.nRight,CWords(iPos).rc.nBottom),,BGColor,BGColor,0
   Graphic Set Font FontsB(CWords(iPos).FontSize)
   Graphic Set Pos (CWords(iPos).rc.nLeft,CWords(iPos).rc.nTop)
   Graphic Color GetColor(CWords(iPos).freq/MaxFreq), -2
   Graphic Print Trim$(CWords(iPos).Text)
   Graphic ReDraw
End Sub
 
Sub CreateFonts
   Local i As Long
   ReDim FontsA(MinFontSize To MaxFontSize)
   ReDim FontsB(MinFontSize To MaxFontSize)
   For i = MinFontSize To MaxFontSize
      Font New FontName, i, 1 To FontsA(i)
      Font New FontName, i, 5 To FontsB(i)
   Next i
End Sub
 
Sub ReDrawCloud
   Local delimiter$,result$,temp$,i,j,w,h,iPos,gW,gH As Long
   MousePtr 11
   'set font sizes, position
   Graphic Color -1, -2
   Graphic Clear BGColor, 0
   For i = 0 To UBound(CWords)
      Graphic Set Font FontsA(CWords(i).FontSize)
      Graphic Set Pos (CWords(i).rc.nLeft,CWords(i).rc.nTop)
      Graphic Color GetColor(CWords(i).freq/MaxFreq), -2
      Graphic Print Trim$(CWords(i).Text)
   Next i
   Graphic ReDraw
   MousePtr 0
End Sub
 
Function GetColor(s As SingleAs Long
   Local ColorLeft, ColorRight As Long
   Local R1,G1,B1,R2,G2,B2 As Long
   ColorLeft = BGColor
   ColorRight = %rgb_DarkRed
 
   R1 = GetRValue(ColorLeft)
   G1 = GetGValue(ColorLeft)
   B1 = GetBValue(ColorLeft)
 
   R2 = GetRValue(ColorRight)
   G2 = GetGValue(ColorRight)
   B2 = GetBValue(ColorRight)
 
   Function = RGB( (R1 + (R2-R1)*s), (G1 + (G2-G1)*s), (B1 + (B2-B1)*s) )
End Function
 
'gbs_01083
'Date: 03-10-2012


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm