1# -*- tcl -*-
2# # ## ### ##### ######## #############
3# (C) 2009 Andreas Kupries
4
5# @@ Meta Begin
6# Package tcl::chan::random 1
7# Meta as::author {Andreas Kupries}
8# Meta as::copyright 2009
9# Meta as::license BSD
10# Meta description Implementation of a channel similar to
11# Meta description Memchan's random channel. Based on Tcl
12# Meta description 8.5's channel reflection support. Exports
13# Meta description a single command for the creation of new
14# Meta description channels. One argument, a list of
15# Meta description numbers to initialize the feedback
16# Meta description register of the internal random number
17# Meta description generator. Result is the handle of the
18# Meta description new channel.
19# Meta platform tcl
20# Meta require TclOO
21# Meta require tcl::chan::events
22# Meta require {Tcl 8.5}
23# @@ Meta End
24
25# # ## ### ##### ######## #############
26
27package require tcl::chan::events
28package require Tcl 8.5
29package require TclOO
30
31# # ## ### ##### ######## #############
32
33namespace eval ::tcl::chan {}
34
35proc ::tcl::chan::random {seed} {
36    return [::chan create {read} [random::implementation new $seed]]
37}
38
39oo::class create ::tcl::chan::random::implementation {
40    superclass tcl::chan::events ; # -> initialize, finalize, watch
41
42    constructor {theseed} {
43	my variable seed next
44	set seed $theseed
45	set next [expr "([join $seed +]) & 0xff"]
46	next
47    }
48
49    method initialize {args} {
50	my allow read
51	next {*}$args
52    }
53
54    # Generate and return a block of N randomly selected bytes, as
55    # requested. Random device.
56
57    method read {c n} {
58	set buffer {}
59	while {$n} {
60	    append buffer [binary format c [my Next]]
61	    incr n -1
62	}
63	return $buffer
64    }
65
66    variable seed
67    variable next
68
69    method Next {} {
70	my variable seed next
71	set result $next
72	set next [expr {(2*$next - [lindex $seed 0]) & 0xff}]
73	set seed [linsert [lrange $seed 1 end] end $result]
74	return $result
75    }
76}
77
78# # ## ### ##### ######## #############
79package provide tcl::chan::random 1
80return
81