[ZB] 2023-06-26 Inspiration was the image on this page: https://pl.pinterest.com/pin/461759768057576269/
======
#!/usr/bin/env tclsh

package require Tk

# We're going to use "expr" a lot, so let's suppress that verbosity a little
# ("m" stands for "math") -- on a second thought: also "lindex --> l"
rename expr m
rename lindex l

proc in { li me } { return [m {([lsearch $li $me] < 0) ? 0 : 1}] }
proc ni { li me } { return [m {([lsearch $li $me] < 0) ? 1 : 0}] }

proc firstFont {fontlist default} {
  set avail {}
  foreach f [font families] { lappend avail [string tolower $f] }
    foreach try $fontlist { if { [in $avail [string tolower $try]] } {
      return $try
    }
  }
  return $default
}

# Having x1, y1, x2, y2 calculate circle's center coordinates and its radius
proc box2cir { x1 y1 x2 y2 } {
  set radius [m {($x2 - $x1)/2}]
  set xc [m {($x1+$x2)/2}]
  set yc [m {($y1+$y2)/2}]
  return [list $xc $yc $radius]
}

# Having center's x, y and radius calculate x1, y1, x2, y2 of the circle
proc circ2box { xc yc radius } {
  set x1 [m {$xc-$radius}]
  set x2 [m {$xc+$radius}]
  set y1 [m {$yc+$radius}]
  set y2 [m {$yc-$radius}]
  return [list $x1 $y1 $x2 $y2]
}

# Cartesian to polar
proc c2p { x y } {
  set r [m {sqrt($x * $x  +  $y * $y)}]
  set a [m {atan($y / $x)}]
  if { $x < 0 || $y < 0 } { set a [m {$a + 3.14159}] }
  if { $x < 0 && $y < 0 } { set a [m {$a + 3.14159}] }
  return [list $a $r]
}

# Polar to Cartesian
proc p2c { a r } { return [list [m {$r * cos($a)}] [m {$r * sin($a)}]] }

# deg to rad
proc d2r { d } { return [m {$d * 3.14159 / 180}] }

# rad to deg
proc r2d { r } { return [m {$r * 180 / 3.14159 }] }


proc prepareEnvironment { path orgX orgY {colour white} {direction ccw} } {
global circlesTable axisTable
  set fontFamily [firstFont {Verdana Arial} Helvetica]
  set width  [m {[$path cget -width]  - $orgX*2}]
  set height [m {[$path cget -height] - $orgY*2}]
  set oneSeventh  [m {$width/7}]
  set halfHeight  [m {$height/2}]
  for { set i 0 } { $i < 8 } { incr i } {
    $path create line [m {$oneSeventh*$i+$orgX}] $orgY \
      [m {$oneSeventh*$i+$orgX}] [m {$height+$orgY}] -fill $colour \
      -tag "vbar_$i"
  }
  for { set i 0 } { $i < 3 } { incr i } {
    $path create line $orgX [m {$halfHeight*$i+$orgY}] \
      [m {$orgX+$width}] [m {$halfHeight*$i+$orgY}] -fill $colour \
      -tag "hbar_$i"
  }
  $path delete "vbar_6"

# Axis of rotation ("Z" axis) -- its coords
  set zx [m {$orgX + $oneSeventh * 5 / 2 }]
  set zy [m {$orgY + $height / 2}]

# Still outer circle
  set x1 [m {$orgX + $oneSeventh * 5 / 2 - $halfHeight}]
  set y1 $orgY
  set x2 [m {$orgX + $oneSeventh * 5 / 2 + $halfHeight}]
  set y2 [m {$orgY+$height}]
  $path create oval $x1 $y1 $x2 $y2 -outline $colour -tag "still"

# Big rolling circle's coords (at 0 deg)
  set x1b [m {$x1 + ($x2-$x1) / 4}]
  set y1b [m {$y1 + ($y2-$y1) / 8}]
  set x2b $x2
  set y2b [m {$y2 - ($y2-$y1) / 8}]
  $path create oval $x1b $y1b $x2b $y2b -outline $colour -tag "big"

# Medium rolling circle's coords
  set x1m [m {$x1 + ($x2-$x1) / 2}]
  set y1m [m {$y1 + ($y2-$y1) / 4}]
  set x2m $x2
  set y2m [m {$y2 - ($y2-$y1) / 4}]
  $path create oval $x1m $y1m $x2m $y2m -outline $colour -tag "medium"

# Small rolling circle's coords
  set x1s [m {$x1 + 3*($x2-$x1) / 4}]
  set y1s [m {$y1 + 3*($y2-$y1) / 8}]
  set x2s $x2
  set y2s [m {$y2 - 3*($y2-$y1) / 8}]
  $path create oval $x1s $y1s $x2s $y2s -outline $colour -tag "small"

# Center of the small circle
  set x1c [m {($x1s+$x2s)/2}]
  set y1c [m {($y1s+$y2s)/2}]

# "Satellite"
  set frac [m {($x2s-$x1s) / 8}]
  set x1sa [m {$x1c-$frac}]
  set y1sa [m {$y1c-$frac}]
  set x2sa [m {$x1c+$frac}]
  set y2sa [m {$y1c+$frac}]
  $path create oval $x1sa $y1sa $x2sa $y2sa -outline red -tag "satellite"

# Moving bars
  $path create line $x1c $orgY $x1c [m {$height+$orgY}] -fill $colour \
      -tag "vertical_bar"
  $path create line $orgX $y1c [m {$width+$orgX-$oneSeventh-$oneSeventh}] $y1c \
      -fill $colour -tag "horizontal_bar"

# The counters
  set xtpos [m {int(6.33 * $oneSeventh)}]
  set ytpos [m {int(0.4 *  $halfHeight)}]
  set smallFontSize [m {int(0.1 *  $halfHeight)}]
  set   bigFontSize [m {int(0.3 *  $halfHeight)}]
  $path create text $xtpos $ytpos -text "input" -fill $colour -tag "input" \
    -font "$fontFamily $smallFontSize"
  $path create text $xtpos [m {$ytpos + 0.4 *  $halfHeight}] -text "000" \
    -fill $colour -tag "upper" -font "$fontFamily $bigFontSize"
  set ytpos [m {int($ytpos + $halfHeight)}]
  $path create text $xtpos $ytpos -text "output" -fill $colour -tag "output" \
    -font "$fontFamily $smallFontSize"
  $path create text $xtpos [m {$ytpos + 0.4 *  $halfHeight}] -text "000" \
    -fill $colour -tag "lower" -font "$fontFamily $bigFontSize"

# The first entry of the final circlesTable (for "0 deg") and axisTable
  lappend circlesTable [list $x1b $y1b $x2b $y2b $x1m $y1m $x2m $y2m \
      $x1s $y1s $x2s $y2s $x1sa $y1sa $x2sa $y2sa]
  lappend axisTable [list $x1c $y1c]

# Translation of coordinates
  set tmp1 [list] ; set tmp2 [list]
  for { set i 0 } { $i < 16 } { incr i 2 } {
    set j [m {$i + 1}] ;# Index for corresponding y
    lappend tmp1 [m {[l [l $circlesTable 0] $i] - $zx}]
    lappend tmp1 [m {$zy - [l [l $circlesTable 0] $j]}]
  }
  lappend tmp2 [m {[l [l $axisTable 0] 0] - $zx}]
  lappend tmp2 [m {$zy - [l [l $axisTable 0] 1]}]

# "Box coordinates" to "center + radius"
  set tmp3 [list]
  set howMany [llength $tmp1]
  for { set i 0 } { $i < $howMany } { incr i 4 } {
    set j [m {$i + 1}] ; set k [m {$i + 2}] ; set l [m {$i + 3}]
    lappend tmp3 [box2cir [l $tmp1 $i] [l $tmp1 $j] [l $tmp1 $k] [l $tmp1 $l]]
  }
  while { [set zz [join $tmp3]] ne $tmp3 } { set tmp3 $zz } ;# Flatten the list

# Cartesian to polar
  set tmp4 [list]
  set howMany [llength $tmp3]
  for { set i 0 } { $i < $howMany } { incr i 3 } {
    set j [m {$i + 1}] ; set k [m {$i + 2}]
    lappend tmp4 [list [c2p [l $tmp3 $i] [l $tmp3 $j]]  [l $tmp3 $k]]
  }
  while { [set zz [join $tmp4]] ne $tmp4 } { set tmp4 $zz } ;# Flatten the list
  set tmp5 [c2p [l $tmp2 0] [l $tmp2 1]]

# Now let's calculate all possible coordinates (step 1 deg)
  set howMany [llength $tmp4]
  for { set d 1 } { $d < 360 } { incr d } {
    if { $direction eq "ccw" } {
      set a [d2r $d]
    } else {
      set a [d2r [m {360 - $d}]]
    }
    set v [list]
    for { set i 0 } { $i < $howMany } { incr i 3 } {
      set j [m {$i + 1}] ; set k [m {$i + 2}]
      set xy [p2c [m {$a + [l $tmp4 $i]}] [l $tmp4 $j]] ;# New Cart. coords
      set xyxy [circ2box [l $xy 0] [l $xy 1] [l $tmp4 $k]] ;# x,y,r --> x1,y1,x2.y2
    # Now back-translation
      lappend v [m {int([l $xyxy 0] + $zx)}]
      lappend v [m {int($zy - [l $xyxy 1])}]
      lappend v [m {int([l $xyxy 2] + $zx)}]
      lappend v [m {int($zy - [l $xyxy 3])}]
    }
  # Row completion
    lappend circlesTable $v

  # Same calculation for "axis" table
    set xya [p2c [m {$a + [l $tmp5 0]}] [l $tmp5 1]] ;# New axis coords
    lappend axisTable [list [m {int([l $xya 0] + $zx)}] [m {int($zy - [l $xya 1])}]]
  }
}

proc rollIt { path twinkle interval } {
global circlesTable axisTable
  set satc [$path itemcget satellite -outline]
  set fgc [$path itemcget horizontal_bar -fill]
  set bgc [$path cget -background]
  set orgX [l [$path coords horizontal_bar] 0]
  set orgY [l [$path coords vertical_bar  ] 1]
  set x2   [l [$path coords horizontal_bar] 2]
  set y2   [l [$path coords vertical_bar  ] 3]
  set width  [m {[$path cget -width]  - $orgX*2}]
  set height [m {[$path cget -height] - $orgY*2}]
  set i 0
  while { 1 } {
    $path coords big       [lrange [l $circlesTable $i]  0 3]
    $path coords medium    [lrange [l $circlesTable $i]  4 7]
    $path coords small     [lrange [l $circlesTable $i]  8 11]
    $path coords satellite [lrange [l $circlesTable $i] 12 15]
    set x1 [l [l $axisTable $i] 0]
    set y1 [l [l $axisTable $i] 1]
    $path coords horizontal_bar $orgX $y1 $x2 $y1
    $path coords vertical_bar $x1 $orgY $x1 $y2
    if { ! [m {$i % 5}] } {
      $path itemconfigure upper -text $i
      $path itemconfigure lower -text [m {int(sin([l [l $circlesTable $i] 0])*180)}]
    }
    if { $twinkle } {
      if { ! [m {$i % 2}] } {
        $path itemconfigure horizontal_bar -fill $bgc
        $path itemconfigure vertical_bar   -fill $bgc
      } else {
        $path itemconfigure horizontal_bar -fill $fgc
        $path itemconfigure vertical_bar   -fill $fgc
      }
      if { ! [m {$i % 30}] } {
        $path itemconfigure satellite -outline $bgc
      } elseif { ! [m {$i % 35}] } {
        $path itemconfigure satellite -outline $satc
      }
    }
    update
    after $interval
    incr i
    set i [m {$i % 360}]
  }
}

# A table that'll hold the data of all points
set circlesTable [list]

# A list that'll will hold the data of rotation axis
set axisTable [list]

set canvasPath .c
pack [canvas $canvasPath -height 600 -width 1150 -background black]
bind . <Escape> { exit 0 }
wm protocol . WM_DELETE_WINDOW { exit 0 }
set Xmargin 50 ; set Ymargin 50
prepareEnvironment $canvasPath $Xmargin $Ymargin white cw ;# „cw” or „ccw”
rollIt $canvasPath yes 20 ;# „yes”=twinkle, frames each 20 ms
======
<<categories>> Graphics | Toys