REBOL [
    Title: "Threads Demo"
    Date: 5-Jan-2005
    Version: 1.0
    Author: "François Jouen"
    File: %threaddemo.r
    Purpose: {
        show multithreading with rebol (all versions)
    }
    library: [
        level: 'intermediate
        platform: 'all
        type: [tool demo] 
        domain: [gui]   
        tested-under: 'win 'Mac Classic 'Linux 'BeOS
        support: none 
        license: 'pd 
    ]
    
]

; Call RThread Library

free-mem: func ['word] [set :word make none! recycle]

Scheduler: func [/local athread ThreadCount] [
	make object! [
	ThreadCount: make integer! 0
	; public properties
	ThreadList: copy []
	Delay: make integer! 0
	;object methods
	AppendThread: func [athread] [append ThreadList athread ThreadCount: ThreadCount + 1]
	RemoveThread: func [id] [remove  at ThreadList id ThreadCount: ThreadCount - 1]
	StartLoop: does [
		for i 1 ThreadCount 1 [
			athread: pick ThreadList i
			athread/TAwake
			if athread/TActivated [athread/TExecute]
			athread/TSleep 0]
		]
	StartMessageLoop: does [
		for i 1 ThreadCount 1 [
			athread: pick ThreadList i
			athread/TCount: athread/TCount + 1
			athread/TGetMessage
			if athread/TActivated [athread/TExecute]
			wait delay

		]
	]
	]
	
]

RTHread: func [ id priority /local Tcount TCall] [
	make object! [
		; define first properties
		TCount: make integer! -1
		TCall: make integer! 0
		TId: id ; Thread number
		TPriority: priority ; thread priority. values: 1 to N  (High to Low)
		TTerminated: make logic! false ; Done?
		TActivated: make logic! false ; Suspended ?
		TFreeOnTerminate: make logic! true ; free memory on terminate
		TMessageList: copy []
		; define now the methods
		TSleep: make function! [value]
		[wait value TActivated: false]
		TAwake: make function! [] 
			[ if not TTerminated [
				TCount: TCount + 1
				tt: remainder TCount TPriority
				if tt == 0 [TActivated: true TCall: TCall + 1]]
		]
		TSendMessage: make function! [athread message] 
		[ 
		      append clear athread/TMessageList message; the message stored in the thread message list
		]
		
		
		TGetMessage: make function! [] 
				[message: last TMessageList
				
				switch message [
					"Activate" [TActivated: true]
					"Suspend" [TActivated: false]
					"Terminate" [TActivated: false TTerminated: true]
				]
				 
		]
		
		TExecute: [] ;please overide this function! 
		TTerminate:  [] ;please overide this function!
	]
]

x: 0
col: white
plot: copy [pen col line]


;first thread routine
Show_Image: does [
	x: x + 1 
	if x > 640 [Clear_Screen ] 
	y: random 450 + 10
	append plot to-pair compose [(x) (y)]
	; suspend the first thread and call the second one
	if not none? t2 [ t1/TsendMessage t1 "Suspend" t1/TsendMessage t2 "Activate"]
	;show points according to the thread priority
	tt: remainder t1/TCount t1/TPriority
	if tt == 0 [show visu]
	
]	
	
Clear_Screen: does [
	x: 0 
	plot: copy [pen col line]  
	append clear visu/effect reduce ['draw plot] 
	show visu
]
;second thread
Show_Time: does [
			; suspend the second thread and call the first one
			if not none? t1 [t2/TsendMessage t2 "Suspend" t2/TsendMessage t1 "Activate"]
			tt: remainder t2/TCount t2/TPriority
			;show time according to the thread priority
			tt: remainder t1/TCount t1/TPriority
			if tt == 0 [  timer/text: now/time  show timer]
]     



; create threads 1 and 2
t1: RThread 1 1
t2: RThread 2 10
; overide TExecute method for each thread
t1/TExecute: :Show_Image
t2/TExecute: :Show_Time
;create Scheduler
sch: Scheduler
;register threads
sch/AppendThread t1
sch/AppendThread t2
; set scheduler delay
sch/Delay: 0
; create messages
t1/TSendMessage  T1 "Activate"
t1/TSendMessage  T2 "Suspend"


mwin: layout [
	across
	at 5x5 visu: box 640x480 blue frame black
	at 5x500 timer: info 150 
	; to show asynchronous event process: modify Thread1 priority
	sl: slider 200x24 [maxi: to-integer sl/data * 60 
						if maxi < 1 [maxi: 1 ] t1/TPriority: maxi slt/text: maxi show slt]
	slt: info 40 "1"	
	
	at 420x500 
	button 50 "Clear" [Clear_Screen]
	button 50 "Start" [maxi: 60 stop: false append visu/effect reduce ['draw plot] 
						until [sch/StartMessageLoop  stop]] ; start scheduler Message Loop processing
	button 50 "Stop" [stop: true]; stop threads
	button 50 "Exit" [ if t1/TFreeOnTerminate [free-mem T1 ]  if t2/TFreeOnTerminate [free-mem T2 ] 
						free-mem sch quit]
	
]
view center-face mwin