The Widget Zoo

#!/usr/bin/env perl
# =============================================================================
#  perl_gui_02_widgets.pl  —  GUI Tutorial Part 2: Widget Showcase
#  Companion to: perl_mac_guide.md  Sections 23–24
#
#  Run with:  perl perl_gui_02_widgets.pl
#  Requires:  Perl/Tk  (cpanm Tk)
#
#  This file teaches:
#    • Checkbutton, Radiobutton
#    • Scale (slider)
#    • Listbox with Scrollbar
#    • BrowseEntry (combo box)
#    • Text widget with tags for styled text
#    • pack, grid, and place layout managers
#    • NoteBook (tabbed panels) — organizing complex UIs
# =============================================================================
use strict;
use warnings;
use Tk;
use Tk::Text;
use Tk::Listbox;
use Tk::Scrollbar;
use Tk::BrowseEntry;
use Tk::NoteBook;

# =============================================================================
# Main Window Setup
# =============================================================================
my $mw = MainWindow->new;
$mw->title("Perl/Tk — Widget Showcase");
$mw->geometry("620x700+80+40");
$mw->configure(-background => "#f2f2f7");

# Title
$mw->Label(
    -text       => "Perl/Tk Widget Showcase",
    -font       => "Helvetica 17 bold",
    -foreground => "#1c1c1e",
    -background => "#f2f2f7",
)->pack(-pady => 12);

# =============================================================================
# NoteBook — Tabbed panels for organizing many widgets
# =============================================================================
# NoteBook gives us tabs. Each tab is a Frame we populate normally.
my $nb = $mw->NoteBook(
    -font        => "Helvetica 11",
    -background  => "#f2f2f7",
)->pack(-fill => "both", -expand => 1, -padx => 10, -pady => 5);

# ── TAB 1: Checkbuttons and Radiobuttons ─────────────────────────────────────
my $tab1 = $nb->add("tab1", -label => " Toggles ");
build_toggles_tab($tab1);

# ── TAB 2: Scale (Slider) ────────────────────────────────────────────────────
my $tab2 = $nb->add("tab2", -label => " Sliders ");
build_sliders_tab($tab2);

# ── TAB 3: Listbox & BrowseEntry ─────────────────────────────────────────────
my $tab3 = $nb->add("tab3", -label => " Lists ");
build_lists_tab($tab3);

# ── TAB 4: Text Widget ───────────────────────────────────────────────────────
my $tab4 = $nb->add("tab4", -label => " Text ");
build_text_tab($tab4);

# ── TAB 5: Layout Managers ───────────────────────────────────────────────────
my $tab5 = $nb->add("tab5", -label => " Layout ");
build_layout_tab($tab5);

# Quit
$mw->Button(
    -text       => "Quit",
    -font       => "Helvetica 11",
    -background => "#ff3b30",
    -foreground => "white",
    -relief     => "flat",
    -padx       => 20, -pady => 6,
    -command    => sub { exit },
)->pack(-pady => 8);

MainLoop;

# =============================================================================
# TAB 1: Checkbuttons and Radiobuttons
# =============================================================================
sub build_toggles_tab {
    my ($f) = @_;
    $f->configure(-background => "#f2f2f7");

    # ── Checkbuttons ──────────────────────────────────────────────────────────
    my $ck_frame = $f->LabelFrame(
        -text       => "Checkbuttons — Independent toggles",
        -font       => "Helvetica 11 bold",
        -background => "#f2f2f7",
    )->pack(-fill => "x", -padx => 15, -pady => 10);

    # Each Checkbutton is bound to its own scalar variable (0 = off, 1 = on)
    my %checks = (
        bold      => 0,
        italic    => 0,
        underline => 0,
        strikeout => 0,
    );

    for my $label (sort keys %checks) {
        $ck_frame->Checkbutton(
            -text        => ucfirst($label),
            -variable    => \$checks{$label},
            -font        => "Helvetica 11",
            -background  => "#f2f2f7",
            -activebackground => "#e5e5ea",
            -command     => sub { show_check_result(\%checks, $f) },
        )->pack(-anchor => "w", -padx => 15, -pady => 2);
    }

    my $ck_result = "Toggle checkboxes above.";
    $f->{ck_result_var} = \$ck_result;
    $ck_frame->Label(
        -textvariable => \$ck_result,
        -font         => "Helvetica 10 italic",
        -foreground   => "#555555",
        -background   => "#f2f2f7",
        -wraplength   => 400,
    )->pack(-padx => 15, -pady => 5, -anchor => "w");

    # ── Radiobuttons ──────────────────────────────────────────────────────────
    my $rb_frame = $f->LabelFrame(
        -text       => "Radiobuttons — Mutually exclusive choices",
        -font       => "Helvetica 11 bold",
        -background => "#f2f2f7",
    )->pack(-fill => "x", -padx => 15, -pady => 10);

    # All Radiobuttons in a group share the SAME -variable.
    # When you click one, all others in the group automatically deselect.
    my $color_choice = "blue";
    my $rb_result    = "Selected: blue";

    my @color_options = (
        ["Red",    "red",    "#ff3b30"],
        ["Blue",   "blue",   "#007aff"],
        ["Green",  "green",  "#34c759"],
        ["Purple", "purple", "#5856d6"],
        ["Orange", "orange", "#ff9500"],
    );

    my $rb_row = $rb_frame->Frame(-background => "#f2f2f7")->pack(
        -fill => "x", -padx => 10, -pady => 5
    );
    for my $opt (@color_options) {
        my ($label, $value, $color) = @$opt;
        $rb_row->Radiobutton(
            -text             => $label,
            -value            => $value,
            -variable         => \$color_choice,
            -font             => "Helvetica 11",
            -foreground       => $color,
            -background       => "#f2f2f7",
            -activebackground => "#e5e5ea",
            -command          => sub {
                $rb_result = "Selected: $color_choice";
            },
        )->pack(-side => "left", -padx => 8);
    }

    $rb_frame->Label(
        -textvariable => \$rb_result,
        -font         => "Helvetica 11 bold",
        -background   => "#f2f2f7",
    )->pack(-pady => 5);

    # Store refs for callback
    $f->{checks}      = \%checks;
    $f->{rb_result}   = \$rb_result;
    $f->{color_choice}= \$color_choice;
}

sub show_check_result {
    my ($checks, $f) = @_;
    my @on = grep { $checks->{$_} } sort keys %$checks;
    my $msg = @on ? "Active: " . join(", ", @on) : "None selected.";
    ${ $f->{ck_result_var} } = $msg if exists $f->{ck_result_var};
}

# =============================================================================
# TAB 2: Scale (Slider)
# =============================================================================
sub build_sliders_tab {
    my ($f) = @_;
    $f->configure(-background => "#f2f2f7");

    # ── Horizontal slider ─────────────────────────────────────────────────────
    my $hframe = $f->LabelFrame(
        -text       => "Horizontal Scale",
        -font       => "Helvetica 11 bold",
        -background => "#f2f2f7",
    )->pack(-fill => "x", -padx => 15, -pady => 10);

    my $volume = 50;
    $hframe->Scale(
        -label        => "Volume",
        -from         => 0,
        -to           => 100,
        -orient       => "horizontal",
        -variable     => \$volume,
        -length       => 350,
        -tickinterval => 25,
        -font         => "Helvetica 10",
        -background   => "#f2f2f7",
        -command      => sub { },   # Called on every change
    )->pack(-padx => 15, -pady => 5);

    my $vol_lbl = $hframe->Label(
        -textvariable => \$volume,
        -font         => "Helvetica 14 bold",
        -foreground   => "#007aff",
        -background   => "#f2f2f7",
    )->pack;

    # ── Vertical slider ───────────────────────────────────────────────────────
    my $vframe = $f->LabelFrame(
        -text       => "Vertical Scales — RGB Color Mixer",
        -font       => "Helvetica 11 bold",
        -background => "#f2f2f7",
    )->pack(-fill => "x", -padx => 15, -pady => 10);

    my ($red, $green, $blue) = (128, 64, 200);
    my $color_preview = "#" . sprintf("%02x%02x%02x", $red, $green, $blue);

    my $preview_lbl = $vframe->Label(
        -text       => "       Color Preview       ",
        -font       => "Helvetica 12 bold",
        -background => $color_preview,
        -relief     => "groove",
        -width      => 30,
    )->pack(-pady => 8);

    # Update the preview when any slider changes
    my $update_color = sub {
        $color_preview = "#" . sprintf("%02x%02x%02x", $red, $green, $blue);
        $preview_lbl->configure(-background => $color_preview);
    };

    my $srow = $vframe->Frame(-background => "#f2f2f7")->pack;
    for my $info (["Red", \$red, "red"], ["Green", \$green, "green"], ["Blue", \$blue, "#007aff"]) {
        my ($name, $var_ref, $color) = @$info;
        my $col = $srow->Frame(-background => "#f2f2f7")->pack(-side => "left", -padx => 20);
        $col->Label(-text => $name, -font => "Helvetica 10 bold",
                    -foreground => $color, -background => "#f2f2f7")->pack;
        $col->Scale(
            -from     => 0,
            -to       => 255,
            -orient   => "vertical",
            -variable => $var_ref,
            -length   => 150,
            -command  => sub { $update_color->() },
            -background => "#f2f2f7",
        )->pack;
        $col->Label(
            -textvariable => $var_ref,
            -font         => "Helvetica 10",
            -background   => "#f2f2f7",
        )->pack;
    }
}

# =============================================================================
# TAB 3: Listbox and BrowseEntry
# =============================================================================
sub build_lists_tab {
    my ($f) = @_;
    $f->configure(-background => "#f2f2f7");

    # ── Listbox with Scrollbar ────────────────────────────────────────────────
    my $lb_frame = $f->LabelFrame(
        -text       => "Listbox with Scrollbar",
        -font       => "Helvetica 11 bold",
        -background => "#f2f2f7",
    )->pack(-fill => "both", -padx => 15, -pady => 10, -expand => 1);

    # Container frame for listbox + scrollbar side by side
    my $lb_box = $lb_frame->Frame(-background => "#f2f2f7")->pack(
        -fill => "both", -expand => 1, -padx => 5, -pady => 5
    );

    my $lb = $lb_box->Listbox(
        -height     => 8,
        -width      => 35,
        -font       => "Helvetica 11",
        -selectmode => "extended",    # Allow multi-select with Shift/Cmd
        -relief     => "sunken",
    )->pack(-side => "left", -fill => "both", -expand => 1);

    my $scrollbar = $lb_box->Scrollbar(
        -command => [$lb, "yview"],   # Scrollbar controls listbox view
    )->pack(-side => "right", -fill => "y");

    # Link the listbox to the scrollbar (two-way binding)
    $lb->configure(-yscrollcommand => [$scrollbar, "set"]);

    # Populate with sample data
    my @fruits = qw(Apple Apricot Banana Blueberry Cherry Coconut Date
                    Elderberry Fig Grape Guava Honeydew Kiwi Lemon Lime
                    Mango Melon Nectarine Orange Papaya Peach Pear Pineapple
                    Plum Pomegranate Raspberry Strawberry Tangerine Watermelon);
    $lb->insert("end", @fruits);

    # Controls
    my $lb_result = "Select item(s) from the list.";
    $lb_frame->Label(
        -textvariable => \$lb_result,
        -font         => "Helvetica 10 italic",
        -foreground   => "#555555",
        -background   => "#f2f2f7",
        -wraplength   => 400,
    )->pack(-padx => 10, -anchor => "w");

    my $ctrl_row = $lb_frame->Frame(-background => "#f2f2f7")->pack(
        -fill => "x", -padx => 5, -pady => 4
    );

    $ctrl_row->Button(
        -text    => "Get Selection",
        -font    => "Helvetica 10",
        -padx    => 8, -pady    => 3,
        -command => sub {
            my @sel = $lb->curselection;
            if (@sel) {
                my @items = map { $lb->get($_) } @sel;
                $lb_result = "Selected: " . join(", ", @items);
            } else {
                $lb_result = "Nothing selected.";
            }
        },
    )->pack(-side => "left", -padx => 3);

    $ctrl_row->Button(
        -text    => "Delete Selected",
        -font    => "Helvetica 10",
        -padx    => 8, -pady    => 3,
        -command => sub {
            my @sel = reverse $lb->curselection;  # Reverse to delete from end
            $lb->delete($_) for @sel;
            $lb_result = "Deleted " . scalar(@sel) . " item(s).";
        },
    )->pack(-side => "left", -padx => 3);

    # Add item field
    my $new_item = "";
    my $add_row  = $lb_frame->Frame(-background => "#f2f2f7")->pack(
        -fill => "x", -padx => 5, -pady => 2
    );
    $add_row->Entry(
        -textvariable => \$new_item,
        -width        => 20,
        -font         => "Helvetica 11",
    )->pack(-side => "left", -padx => 3);
    $add_row->Button(
        -text    => "Add Item",
        -font    => "Helvetica 10",
        -padx    => 8, -pady => 3,
        -command => sub {
            return unless $new_item;
            $lb->insert("end", $new_item);
            $lb->see("end");    # Scroll to show new item
            $lb_result = "Added: $new_item";
            $new_item  = "";
        },
    )->pack(-side => "left", -padx => 3);

    # ── BrowseEntry (Combo Box) ───────────────────────────────────────────────
    my $be_frame = $f->LabelFrame(
        -text       => "BrowseEntry (Dropdown Combo Box)",
        -font       => "Helvetica 11 bold",
        -background => "#f2f2f7",
    )->pack(-fill => "x", -padx => 15, -pady => 5);

    my $lang_choice = "Perl";
    my $be_result   = "Selected language: Perl";
    my @languages   = qw(Perl Python Ruby JavaScript Go Rust Swift Kotlin Java C C++);

    my $be_row = $be_frame->Frame(-background => "#f2f2f7")->pack(
        -fill => "x", -padx => 10, -pady => 8
    );
    $be_row->Label(-text => "Language:", -background => "#f2f2f7",
                   -font => "Helvetica 11")->pack(-side => "left");

    my $be = $be_row->BrowseEntry(
        -variable => \$lang_choice,
        -width    => 20,
        -font     => "Helvetica 11",
        -browsecmd => sub { $be_result = "Selected: $lang_choice" },
    )->pack(-side => "left", -padx => 8);

    $be->insert("end", $_) for @languages;

    $be_frame->Label(
        -textvariable => \$be_result,
        -font         => "Helvetica 10 italic",
        -foreground   => "#555555",
        -background   => "#f2f2f7",
    )->pack(-padx => 10, -pady => 3, -anchor => "w");
}

# =============================================================================
# TAB 4: Text Widget
# =============================================================================
sub build_text_tab {
    my ($f) = @_;
    $f->configure(-background => "#f2f2f7");

    my $tf = $f->LabelFrame(
        -text       => "Text Widget — Multi-line with Styled Tags",
        -font       => "Helvetica 11 bold",
        -background => "#f2f2f7",
    )->pack(-fill => "both", -expand => 1, -padx => 15, -pady => 10);

    # Text + vertical scrollbar
    my $tbox = $tf->Frame(-background => "#f2f2f7")->pack(
        -fill => "both", -expand => 1, -padx => 5, -pady => 5
    );
    my $text = $tbox->Text(
        -width      => 55,
        -height     => 12,
        -font       => "Courier 11",
        -wrap       => "word",
        -relief     => "sunken",
        -background => "white",
    )->pack(-side => "left", -fill => "both", -expand => 1);

    my $tsb = $tbox->Scrollbar(-command => [$text, "yview"])->pack(
        -side => "right", -fill => "y"
    );
    $text->configure(-yscrollcommand => [$tsb, "set"]);

    # Define text tags for styling
    $text->tagConfigure("heading",  -font => "Helvetica 13 bold",
                                     -foreground => "#1c1c1e");
    $text->tagConfigure("bold",     -font => "Courier 11 bold");
    $text->tagConfigure("italic",   -font => "Courier 11 italic");
    $text->tagConfigure("red",      -foreground => "red");
    $text->tagConfigure("blue",     -foreground => "#007aff");
    $text->tagConfigure("green",    -foreground => "#34c759");
    $text->tagConfigure("hilite",   -background => "#ffffa0");
    $text->tagConfigure("code",     -font => "Courier 11",
                                     -background => "#f0f0f0",
                                     -relief => "flat");
    $text->tagConfigure("link",     -foreground => "#007aff",
                                     -underline  => 1);

    # Insert styled text demonstrating tags
    $text->insert("end", "Perl/Tk Text Widget Demo\n",      "heading");
    $text->insert("end", "\n");
    $text->insert("end", "This is ");
    $text->insert("end", "bold text", "bold");
    $text->insert("end", " and this is ");
    $text->insert("end", "italic text", "italic");
    $text->insert("end", ".\n");
    $text->insert("end", "Red text, ", "red");
    $text->insert("end", "blue text, ", "blue");
    $text->insert("end", "green text.\n", "green");
    $text->insert("end", "\nHighlighted: ");
    $text->insert("end", "this text is highlighted in yellow", "hilite");
    $text->insert("end", ".\n");
    $text->insert("end", "\nCode block:\n");
    $text->insert("end", "    my \$x = 42;\n    print \$x * 2;\n", "code");
    $text->insert("end", "\nA clickable ");
    $text->insert("end", "link here", "link");
    $text->insert("end", " (bound to a click event).\n");

    # Bind click on the "link" tag
    $text->tagBind("link", "<Button-1>", sub {
        $mw->messageBox(
            -title   => "Link Clicked",
            -message => "You clicked the link!\nIn a real app this would open a URL.",
            -type    => "OK", -icon => "info"
        );
    });
    $text->tagBind("link", "<Enter>", sub { $text->configure(-cursor => "hand2") });
    $text->tagBind("link", "<Leave>", sub { $text->configure(-cursor => "xterm") });

    # Control buttons
    my $ctrl = $tf->Frame(-background => "#f2f2f7")->pack(-fill => "x", -padx => 5);

    $ctrl->Button(-text => "Get All Text", -font => "Helvetica 10",
                  -padx => 6, -pady => 3,
                  -command => sub {
                      my $content = $text->get("1.0", "end");
                      my $lines   = scalar(split /\n/, $content);
                      $mw->messageBox(-title => "Content",
                          -message => "Text has $lines lines and "
                                    . length($content) . " characters.",
                          -type => "OK", -icon => "info");
                  })->pack(-side => "left", -padx => 3, -pady => 4);

    $ctrl->Button(-text => "Clear All", -font => "Helvetica 10",
                  -padx => 6, -pady => 3,
                  -command => sub { $text->delete("1.0", "end") }
                 )->pack(-side => "left", -padx => 3);

    $ctrl->Button(-text => "Append Line", -font => "Helvetica 10",
                  -padx => 6, -pady => 3,
                  -command => sub {
                      $text->insert("end", "Appended line at " . localtime() . "\n");
                      $text->see("end");
                  })->pack(-side => "left", -padx => 3);
}

# =============================================================================
# TAB 5: Layout Managers
# =============================================================================
sub build_layout_tab {
    my ($f) = @_;
    $f->configure(-background => "#f2f2f7");

    # ── pack ──────────────────────────────────────────────────────────────────
    my $pack_frame = $f->LabelFrame(
        -text       => "pack — flow layout",
        -font       => "Helvetica 11 bold",
        -background => "#f2f2f7",
    )->pack(-fill => "x", -padx => 15, -pady => 8);

    for my $info (
        ["-side => 'top'   -fill => 'x'",    "top",   "x",    0, "#e8f4f8"],
        ["-side => 'left'  -fill => 'y'",    "left",  "y",    0, "#fef9e7"],
        ["-side => 'left'  -expand => 1",    "left",  "both", 1, "#eafaf1"],
        ["-side => 'right' -anchor => 'e'",  "right", "none", 0, "#fdf2f8"],
    ) {
        my ($desc, $side, $fill, $exp, $bg) = @$info;
        $pack_frame->Label(
            -text       => $desc,
            -font       => "Courier 9",
            -background => $bg,
            -relief     => "groove",
            -padx       => 4, -pady => 2,
        )->pack(-side => $side, -fill => $fill, -expand => $exp, -padx => 2, -pady => 1);
    }

    # ── grid ──────────────────────────────────────────────────────────────────
    my $grid_frame = $f->LabelFrame(
        -text       => "grid — table layout (ideal for forms)",
        -font       => "Helvetica 11 bold",
        -background => "#f2f2f7",
    )->pack(-fill => "x", -padx => 15, -pady => 8);

    # Configure column weights so column 1 stretches
    $grid_frame->gridColumnconfigure(0, -weight => 0);
    $grid_frame->gridColumnconfigure(1, -weight => 1);

    my @form_fields = ("First Name", "Last Name", "Email", "Phone");
    my %form_vals;
    for my $i (0 .. $#form_fields) {
        my $field = $form_fields[$i];
        # Label in column 0, right-aligned
        $grid_frame->Label(
            -text       => "$field:",
            -font       => "Helvetica 10",
            -background => "#f2f2f7",
            -anchor     => "e",
        )->grid(-row => $i, -column => 0, -sticky => "e", -padx => 5, -pady => 2);

        # Entry in column 1, stretches with window
        $grid_frame->Entry(
            -textvariable => \$form_vals{$field},
            -font         => "Helvetica 10",
            -width        => 25,
        )->grid(-row => $i, -column => 1, -sticky => "ew", -padx => 5, -pady => 2);
    }
    # Submit button spanning 2 columns
    $grid_frame->Button(
        -text    => "Submit Form",
        -font    => "Helvetica 10",
        -padx    => 10, -pady => 3,
        -command => sub {
            my @parts;
            for my $f2 (@form_fields) {
                push @parts, "$f2: " . ($form_vals{$f2} // "");
            }
            $mw->messageBox(-title => "Form Data",
                             -message => join("\n", @parts),
                             -type => "OK", -icon => "info");
        },
    )->grid(-row => scalar @form_fields, -column => 0,
            -columnspan => 2, -pady => 6);

    # ── place ─────────────────────────────────────────────────────────────────
    my $place_frame = $f->LabelFrame(
        -text       => "place — absolute positioning",
        -font       => "Helvetica 11 bold",
        -background => "#f2f2f7",
        -height     => 70,
    )->pack(-fill => "x", -padx => 15, -pady => 8);
    $place_frame->packPropagate(0);  # Prevent frame from shrinking

    for my $info (
        ["Top-Left",   0.0,  0.0],
        ["Top-Right",  1.0,  0.0],
        ["Center",     0.5,  0.5],
        ["Bot-Left",   0.0,  1.0],
        ["Bot-Right",  1.0,  1.0],
    ) {
        my ($label, $rx, $ry) = @$info;
        $place_frame->Label(
            -text       => $label,
            -font       => "Helvetica 8",
            -background => "#e0e0ff",
            -relief     => "raised",
        )->place(-relx => $rx, -rely => $ry, -anchor => "center");
    }
}