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