| 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 |