Tourbillon Watch Desktop Widget for Windows 8+ (Red Programming Language)

tourbillon-watch-widget.red

Red [
    title: "Tourbillon Watch Desktop Widget for Windows 8+"
    author: "hinjolicious"
    note: {
        Idea: @hiiamboris work on "Cellestial Clock".
        Collaborator: Gemini AI
        Tested: on Red Toolchain v0.66 in Windows 11
        June 13th, 2026
    }
    needs: 'view
]

w8+?: not find get in os-info 'name "Windows 7"
; >> os-info
;== make object! [
;    name: "Windows 11"
;    arch: 'x86-64
;    version: 10.0.0
;    build: 22621
;]
;>> find get in os-info 'name "Windows"
;== "Windows 11" ==> return true if not windows 7

on-over: [if event/down? [w/offset: w/offset + event/offset]] ; to drag app window
w-flags: [no-title no-border all-over]

; --- Visual Assets Definitions ---
back-plate: [pen coal line-width 1 circle 200x200 190]
pin-s: [circle 0x0 5]
pin: [circle 0x0 15]
scales-s: compose append/dup [] [line-width 1 pen gray [rotate 1 0x0 line 0x-185 0x-190]] 360
scales-m: compose append/dup [] [line-width 1 pen gray [rotate 6 0x0 line 0x-165 0x-190]] 100
scales-h: compose append/dup [] [rotate 30 0x0 shape [move 0x-150 line 4x-150 4x-180 -4x-180 -4x-150 close]] 12

h-sec:   [rot-sec: rotate 0 0x0 shape [
    move 0x-185 line 
    1x-183 1x-135  8x-110  2x-103  5x50 
    -5x50  -2x-103 -8x-110 -1x-135 -1x-183 close]]
h-min:   [rot-min: rotate 0 0x0 shape [move 0x-165 line 5x-155 5x0 -5x0 -5x-155 close]]
h-hour:  [rot-hour: rotate 0 0x0 shape [move 0x-130 line 5x-120 5x0 -5x0 -5x-120 close]]

twelve: [shape [move 0x-135 line 12x-180 -12x-180 close]]
shadow: [translate (4, 4) pen off fill-pen 0.0.0.150]

; left sub-dial (month)
months: compose append/dup [][line-width 2 pen gray [rotate 30 0x0 line 0x-45 0x-55]] 12
h-month: [rot-mon: rotate 0 0x0 shape [move 1x-35 line 5x5 -5x5 -1x-35 close]]

; right sub-dial (weekday)
dow: compose append/dup [][line-width 2 pen gray [rotate 51.42857142857143 0x0 line 0x-45 0x-55]] 7
h-dow: [rot-dow: rotate 0 0x0 shape [move 1x-35 line 5x5 -5x5 -1x-35 close]]

; tourbillon gears
escape-wheel-teeth: compose append/dup [][
    rotate 18 0x0 shape [move -1x-18 line 6x-27 7x-26 5x-23 7x-18 close]] 20
escape-wheel: compose [rot-escape-wheel: rotate 0 0x0
    pen off fill-pen gray 
    (escape-wheel-teeth) 
    box -2x-19 2x19 box -19x-2 19x2]

hairspring: collect [repeat r 30 [if r % 3 = 0 [keep compose [circle 0x0 (r)]] ]]
hairspring-scale: compose [
    pen gray line-width 1
    scale-hairspring: scale 1 1 (hairspring)]

; balance wheel
ballance-wheel-screws: compose append/dup [][rotate 90 0x0 box -3x-45 3x-35] 4
ballance-wheel: compose [rot-balance-wheel: rotate 0 0x0
    pen off fill-pen linear gold 0.0 black 1.5
    (ballance-wheel-screws) 
    rotate 45 box -4x-40 4x40
    pen linear gold 0.0 black 3.5 line-width 5 fill-pen off circle 0x0 40
]

deep-gear-teeth: compose append/dup [][rotate 5 0x0 shape [move 0x-40 line 2x-35 -2x-35 close]] 72
deep-gear: compose [
    pen off fill-pen linear coal 0.0 black 1.5
    (deep-gear-teeth)
    circle 0x0 35]
    
cage-spokes: compose append/dup [] [rotate 120 0x0 
    fill-pen linear silver 0.0 black 1.5 
    box -5x-55 5x0 
    circle 0x-55 8
    fill-pen #3333aa circle 0x-55 6
		;fill-pen blue circle 0x-60 5
    ] 3
cage-spokes-shadow: compose append/dup [] [rotate 120 0x0 
    box -5x-55 5x0 
    circle 0x-55 8
    ] 3    

top-cage: compose/deep/only [
    fill-pen off line-width 5 
	pen linear silver 0.0 black 1.5 shape [move -48x28 arc 48x28 55 55 240 sweep large]
    pen off [(cage-spokes)]
    pen off fill-pen linear silver 0.0 black 1.5 circle 0x0 12
    fill-pen linear #ffaaff 0.0 #aa00aa 1.5 circle 0x0 8
		;fill-pen pink circle 0x0 7
]
top-cage-shadow: compose/deep/only [
    [(cage-spokes-shadow)]
    circle 0x0 10
]
cage: compose/deep/only [rot-cage: rotate 0 0x0
	; no pallet fork yet!
    translate 0x38 [(escape-wheel)]
    push [
        translate 0x38 
        line-width 8 pen linear silver 0.0 black 1.5 line 0x0 0x-38 
        pen off fill-pen linear silver 0.0 black 1.5 circle 0x0 9 
        fill-pen linear #ffaaff 0.0 #aa00aa 1.5 circle 0x0 6
			;fill-pen pink circle 0x0 5
    ]
    push (ballance-wheel)
    push (hairspring-scale)
    push [(shadow) (top-cage-shadow)] push (top-cage)
]

drawing: compose/deep/only [
		scale 1.0 1.0
		push [pen off 
			fill-pen linear 10.10.10 0.5 silver 3.5 circle 200x200 197 
			fill-pen 20.20.20 circle 200x200 145]
			
		; brand
		push [translate 200x200
			font (make font! [size: 20 style: 'normal]) pen red text -25x-116 "RED"
			font (make font! [size: 12 style: 'italic]) pen gray text -44x-85 "The Reducer"
			font (make font! [size: 10 style: 'normal]) text -47x-65 "PROFESSIONAL"]
		
		; Left sub-dial
		push [pen off 
			fill-pen linear 10.10.10 0.5 silver 3.5 circle 115x200 59 
			fill-pen 20.20.20 circle 115x200 40]
			
		push [translate 115x200 
			push (months) 
			fill-pen linear white 0.0 black 1.5 
			push [(shadow) (h-month)] push (h-month)
			pen gray text -15x-35 "Month"
			font (make font! [size: 12 style: 'normal]) text -36x-12 (form now/day)]

		; Right sub-dial
		push [pen off 
			fill-pen linear 10.10.10 0.5 silver 3.5 circle 285x200 59 
			fill-pen 20.20.20 circle 285x200 40]
			
		push [translate 285x200 
			push (dow) 
			fill-pen linear white 0.0 black 1.5 
			push [(shadow) (h-dow)] push (h-dow) 
			pen gray text -20x-35 "Weekday"
			font (make font! [size: 12 style: 'normal]) text 12x-12 (form either now/time > 12:0:0 ["PM"]["AM"])
		]
		
		; Scales
		push [translate 200x200 pen off 
			push (scales-s) push (scales-m) 
			fill-pen linear silver 0.0 black 1.5
			push [(shadow) (scales-h)] push (scales-h)
			push [(shadow) (twelve)] push (twelve)]
		
		; Tourbillon window
		push [ 
			fill-pen linear black 0.0 silver 1.5 circle 200x300 70
			fill-pen black circle 200x300 65]
		
		; Tourbillon core
		push [translate 200x300 
			push (deep-gear)
			push (cage)]
		
		; Hands Layer
		push [translate 200x200 
			line-join bevel pen off 
			fill-pen linear white 0.0 black 1.5 
			push [(shadow) (h-hour)] push (h-hour) 
			push [(shadow) (h-min)] push (h-min) (pin)
			fill-pen linear red 0.0 black 1.5
			push [(shadow) (h-sec)] push (h-sec) (pin-s)
		]
		
	]
	
app-body: compose [
	title "Tourbillon"
	backdrop black
	box: box 400x400
	
	draw drawing
	rate 99 on-time [
		ftime: to-float time: now/time/precise
		
		; main dial calculations
		rot-sec/2:  ftime % 60 * 6
		rot-min/2:  ftime % 3600 / 10
		rot-hour/2: ftime / 120
		
		; left sub-dial
		mo: now/month		rot-mon/2: mo % 12 * 30 
		; right sub-dial
		wd: now/weekday		rot-dow/2: wd % 7 * 51.42857142857143
		
		; tourbillon

		; --- HIGH-REALISM, BUTTERY-SMOOTH TOURBILLON ENGINE ---
		rot-cage/2: rot-sec/2
		
		; 1. Smooth Balance Wheel Oscillation
        ; Dropping from 1000.0 to 12.0 slows down the raw radian velocity 
        ; to a perfectly rhythmic, hardware-frame-locked 3.8Hz beat.
        ; We use 80.0 degrees to ensure smooth frame steps on 60Hz displays.
		balance-angle: 80.0 * sin (ftime * 12.0)
		rot-balance-wheel/2: balance-angle
		
		; 2. Fluid Escape Wheel Transmission
        ; Keeps the rapid step-vibration look but anchors it tightly to the cage rotation
		;rot-escape-wheel/2: (rot-sec/2 * 4.0) + (4.0 * sin (ftime * 12.0))
		rot-escape-wheel/2: (rot-sec/2 * 4.0) + (2.0 * sin (ftime * 12.0))
		
		; 3. Phase-Locked Hairspring Breathing
        ; Tied perfectly to the new smooth angle matrix
		scale-hairspring/2: 1.0 - (balance-angle / 600.0)
		scale-hairspring/3: scale-hairspring/2        
		
		show box
		;print [mold sizing copy/part face/draw 3]
	]
]

app-options: compose/deep [ ; win 8+
	draw: [fill-pen coal box 10x10 20x20] ; draw anchor dot, needed for dragging!!!
	actors: object [
		on-over: func [face event] [(on-over)]
		on-alt-down: func [face event] [ ; right click
			mouse-pos: event/offset
			if all [mouse-pos/x >= 10  mouse-pos/x <= 20  mouse-pos/y >= 10  mouse-pos/y <= 20][ 
				view/flags [title "What?" panel [
					below
					button "Full" [drawing/2: 1.0 drawing/3: 1.0 show box]
					button "Half" [drawing/2: 0.5 drawing/3: 0.5 show box]
					button "Third" [drawing/2: 0.33 drawing/3: 0.33 show box]
					button "Quit" [quit]
				]][modal popup]
			]
		]
	]
]

w-body: compose/deep pick [
    [(app-body)] ;w8+
    [all-over on-over [(on-over)]] ;w7
] w8+?
w-options: compose/deep pick [
	[(app-options)] ;w8+
    [] ; w7 (empty!)
] w8+?

w: view/tight/no-wait/flags/options w-body w-flags w-options

; --- Native OS API Hooks ---
#system [#import ["user32.dll" stdcall [
	GetActiveWindow: "GetActiveWindow" [
		return: [handle!]
	]
	SetWindowLong: "SetWindowLongW" [
		hWnd            [handle!]
		nIndex          [integer!]
		dwNewLong       [integer!]
		return:         [integer!]
	]
	SetLayeredWindowAttributes: "SetLayeredWindowAttributes" [
		hWnd            [handle!]
		crKey           [integer!]
		bAlpha          [integer!]
		dwFlags         [integer!]
		return:         [integer!]
	]
	SetWindowPos: "SetWindowPos" [
		hWnd            [handle!]
		hWndInsertAfter [integer!]  ; Can accept special constants like -1
		X               [integer!]
		Y               [integer!]
		cx              [integer!]
		cy              [integer!]
		uFlags          [integer!]
		return:         [integer!]
	]
]]]

hack-it-w7: routine [hred [handle!] /local hwnd [handle!]] [
    hwnd: as handle! hred/value
    SetWindowLong hwnd -20 00080000h
    SetLayeredWindowAttributes hwnd 0 0 2
	SetWindowPos hwnd -1 0 0 0 0 0043h ; -1 = HWND_TOPMOST
]
hack-it-w8+: routine [hred [handle!] /local hwnd [handle!]] [
    hwnd: as handle! hred/value
    SetWindowLong hwnd -20 00080000h
    SetLayeredWindowAttributes hwnd 0 0 1
	SetWindowPos hwnd -1 0 0 0 0 0043h ; -1 = HWND_TOPMOST
]
hack-it: function [f [object!]] [
    h: f/state/1 
    either w8+? [hack-it-w8+ h][hack-it-w7 h]
]
hack-it w

do-events 

Preview: