The task is to produce a matrix of 20 hexagon shaped widgets in a honeycomb arrangement. The matrix should be arranged in such a manner that there are five
columns of four hexagons. The hexagons in columns one, three and five are aligned horizontally, whereas the hexagons in columns two and four occupy a lower position within the arrangement. Each hexagon should be the same colour, and should
display a unique randomly selected single capital letter on the front. The application should now wait for the user to select a hexagon, either by using a pointing device, or by pressing a key that carries a corresponding letter on a hexagon. For platforms that support pointing devices and keyboards, the application should support both methods of selection. A record of the chosen letters should be maintained and the code should be suitably commented, at the point where the the selected letter has been determined. The selected hexagon should now change colour on the display. The cycle repeats until the user has chosen all of the letters. Note that each letter can only be selected once and previously selected hexagons retain their colour after selection. The program terminates when all letters have been chosen.

Optionally: output the list of selected letters and show the last selected letter, cater for a different number of columns or a different number of hexagons in each column, cater for two players, (turns alternate and the hexagons change a different colour depending on whether they were selected by player one or player two and records of both players selections are maintained.)



link printf
 
procedure main(A)
   h := (0 < integer(\A[1])) | 4             # cells high
   w := (0 < integer(\A[2])) | 5             # cells wide
   u := (10 < integer(\A[3])) | 30           # length of cell side
   HoneyComb(h,w,u)                 
end
 
$define INACTIVE "light yellow"
$define ACTIVE   "light purple"
 
procedure HoneyComb(h,w,u)                   #: run HoneyComb demo
 
   wb := u/2                                 # window border
   wmsg := 10                                # . message space
   ww := 2*wb + u*(3*w+1)/2                  # . width 
   wh := 2*wb+wmsg+integer((h+1)*u*sqrt(3.)) # . height  
 
   chosen := sprintf("black,%d",wb)
   fine   := sprintf("black,%d",wmsg)
 
   wparms := [ title := sprintf("HoneyComb-%dx%d",h,w),
               "g","bg=white","fg=black",
               sprintf("size=%d,%d",ww,wh) ]
   &window := open!wparms | stop("Unable to open window")
 
   alpha := &ucase                           # per original spec
   if h*w > *alpha then alpha ++:= &lcase    # more 
   if h*w > *alpha then alpha ++:= &digits   # more again
   if h*w > *alpha then 
      stop("More than ",*alpha," cells.")    # choke
 
   every put(letters := [],!string(alpha))
   every !letters :=: ?letters               # randomize
 
   Widgets := []                             # prepare widgets 
   every c := 1 to w do {                    # layout grid of cells
      if /top then                           # start at top left
         x := y := wb
      else {                                 # continue right from top
         x := top.rx
         y := if c % 2 = 0 then top.ry0 else top.ry1
         }
      put(Widgets,W := top := HexWidget(x,y,u,get(letters)))
      every 2 to h do                        # fill in rest of column
         put(Widgets,W := HexWidget(x := W.dx,y := W.dy,u,get(letters)))      
      }   
 
   activated := ""
   until *activated = *Widgets do {          # process widgets
      e := Event()
      every W := !Widgets do                          # select widget by 
         if ((e == &lpress) & W.inside(W,&x,&y)) |    # mouse (left press) or
            (e == W.s) then                           # label character 
               if not find(W.s,activated) then        # activate if new 
                  break activated ||:= ( DrawCell(W,ACTIVE), W.s)     
      Font(chosen)
      DrawString(wb,wh-wb-wmsg,"Chosen: "||activated) # update selected list
      }    
   WriteImage(sprintf("%s-%d.gif",title,&now))        # save file
   Font(fine)                                         # tell how to quit
   DrawString(wb,wh-wmsg,"Right click to exit")
   until Event() == &rpress            
   close(&window)
end
 
record HexWidgetData(s,u,w,h,ax,ay,cx,cy,poly,xx,xy,dx,dy,rx,ry0,ry1,inside) 
 
procedure HexWidget(ax,ay,u,s)               #: create widget s @ x,y & side u
/u := 20.                                    # side
x := integer(0 <= ax) | runerr(205,ax)       # ensure whole numbers
y := integer(0 <= ay) | runerr(205,ay)
u := integer(1 <= u)  | runerr(205,u)        # 1 is minimal if ridiculous
h := integer(sqrt(3./4) * (w := 2 * u))      # h,w
W := HexWidgetData(s,u,w,h,                  # string, side, width and height
                  ax,ay,                     # absolute x,y
                  ax+w/2,ay+h/2,             # center x,y 
                  [ax+u/2,ay, ax+(3*u)/2,ay, ax+2*u,ay+h/2, 
                   ax+(3*u)/2,ay+h, ax+u/2,ay+h, ax,ay+h/2],  # to draw polygon
                   -u/2,h/2,                 # const for z of cross product
                   x,ay+h,                   # next cell down
                   ax+(3*u)/2,ay+h/2,ay-h/2, # next cells right up/down
                   InHexWidget)              # is it activated proc
return DrawCell(W,INACTIVE)
end
 
procedure DrawCell(W,colour)                 #: Draw the (general) Widget
   Fg(colour)
   FillPolygon!W.poly                        # can draw any polygon
   Fg("black")
   DrawPolygon!W.poly 
   Font(sprintf("Helvetica,%d",integer(W.h/2.)))
   DrawString(W.cx - TextWidth(W.s)/2,
               W.cy + (WAttrib("ascent") - WAttrib("descent"))/2 + 1,W.s)
   return W
end
 
procedure InHexWidget(W,x,y)                 #: return W if x,y are inside W
   if W.w < 0 then W.ax -:= (W.w := -W.w)                       # fix if -w
   if W.h < 0 then W.ay -:= (W.h := -W.h)                       # fix if -h
   if (0 < x - W.ax < W.w) & (0 < y - W.ay < W.h) then {        # disallow edge
      if x > W.cx then x := W.cx - (x - W.cx)                   # reflect x->NW
      if y > W.cy then y := W.cy - (y - W.cy)                   # reflect y->NW
      if 0 > real(W.xx)*(y-W.poly[2]) - W.xy*(x-W.poly[1]) then # z from cross
         return W
      }
end