From b8f24a303a4778882b29e2be1743af9ebad43087 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 10:36:24 -0500 Subject: [PATCH 01/11] scaffold-help now prints $var-description for symbols --- basis/tools/scaffold/scaffold.factor | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 16729394bf..4b4b625fa7 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -5,7 +5,7 @@ io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader io combinators calendar accessors math.parser io.streams.string ui.tools.operations quotations strings arrays prettyprint words vocabs sorting sets classes math alien urls -splitting ascii combinators.short-circuit ; +splitting ascii combinators.short-circuit alarms words.symbol ; IN: tools.scaffold SYMBOL: developer-name @@ -116,6 +116,7 @@ ERROR: no-vocab vocab ; { "ch" "a character" } { "word" word } { "array" array } + { "alarm" alarm } { "duration" duration } { "path" "a pathname string" } { "vocab" "a vocabulary specifier" } @@ -162,15 +163,26 @@ ERROR: no-vocab vocab ; ] if ] when* ; +: symbol-description. ( word -- ) + drop + "{ $var-description \"\" } ;" print ; + : $description. ( word -- ) drop "{ $description \"\" } ;" print ; +: docs-body. ( word/symbol -- ) + dup symbol? [ + symbol-description. + ] [ + [ $values. ] [ $description. ] bi + ] if ; + : docs-header. ( word -- ) "HELP: " write name>> print ; : (help.) ( word -- ) - [ docs-header. ] [ $values. ] [ $description. ] tri ; + [ docs-header. ] [ docs-body. ] bi ; : interesting-words ( vocab -- array ) words From 4bd8583254e74fe6d8d256c9b7a8c983d1f4df88 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 10:51:38 -0500 Subject: [PATCH 02/11] fix spacing issue --- basis/tools/scaffold/scaffold.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 4b4b625fa7..6280f993cc 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -135,7 +135,7 @@ ERROR: no-vocab vocab ; : ($values.) ( array -- ) [ - " { " write + "{ " write dup array? [ first ] when dup lookup-type [ [ unparse write bl ] From 3c6ceb1891de419011d6e779e5de5ea62300678b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 10:53:51 -0500 Subject: [PATCH 03/11] initial checkin of site-watcher --- extra/site-watcher/authors.txt | 1 + extra/site-watcher/site-watcher-docs.factor | 60 +++++++++++ extra/site-watcher/site-watcher.factor | 114 ++++++++++++++++++++ 3 files changed, 175 insertions(+) create mode 100644 extra/site-watcher/authors.txt create mode 100644 extra/site-watcher/site-watcher-docs.factor create mode 100644 extra/site-watcher/site-watcher.factor diff --git a/extra/site-watcher/authors.txt b/extra/site-watcher/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/site-watcher/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/site-watcher/site-watcher-docs.factor b/extra/site-watcher/site-watcher-docs.factor new file mode 100644 index 0000000000..37a1cf138d --- /dev/null +++ b/extra/site-watcher/site-watcher-docs.factor @@ -0,0 +1,60 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs help.markup help.syntax kernel urls alarms calendar ; +IN: site-watcher + +HELP: run-site-watcher +{ $description "Starts the site-watcher on the assoc stored in " { $link sites } "." } ; + +HELP: running-site-watcher +{ $var-description "A symbol storing the alarm of a running site-watcher if started with the " { $link run-site-watcher } " word. To prevent multiple site-watchers from running, this variable is checked before allowing another site-watcher to start." } ; + +HELP: site-watcher-from +{ $var-description "The email address from which site-watcher sends emails." } ; + +HELP: sites +{ $var-description "A symbol storing an assoc of URLs, data about a site, and who to notify if a site goes down." } ; + +HELP: watch-site +{ $values + { "emails" "a string containing an email address, or an array of such" } + { "url" url } +} +{ $description "Adds a new site to the watch assoc stored in " { $link sites } ", or adds email addresses to an already watched site." } ; + +HELP: watch-sites +{ $values + { "assoc" assoc } + { "alarm" alarm } +} +{ $description "Runs the site-watcher on the input assoc and returns the alarm that times the site check loop. This alarm may be turned off with " { $link cancel-alarm } ", thus stopping the site-watcher." } ; + +HELP: site-watcher-frequency +{ $var-description "A " { $link duration } " specifying how long to wait between checking sites." } ; + +HELP: unwatch-site +{ $values + { "emails" "a string containing an email, or an array of such" } + { "url" url } +} +{ $description "Removes an email address from being notified when a site's goes down. If this email was the last one watching the site, removes the site as well." } ; + +HELP: delete-site +{ $values + { "url" url } +} +{ $description "Removes a watched site from the " { $link sites } " assoc." } ; + +ARTICLE: "site-watcher" "Site watcher" +"The " { $vocab-link "site-watcher" } " vocabulary monitors websites and sends email when a site goes down or comes up." $nl +"To monitor a site:" +{ $subsection watch-site } +"To stop email addresses from being notified if a site's status changes:" +{ $subsection unwatch-site } +"To stop monitoring a site for all email addresses:" +{ $subsection delete-site } +"To run site-watcher using the sites variable:" +{ $subsection run-site-watcher } +; + +ABOUT: "site-watcher" diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor new file mode 100644 index 0000000000..c538b12ed1 --- /dev/null +++ b/extra/site-watcher/site-watcher.factor @@ -0,0 +1,114 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alarms assocs calendar combinators +continuations fry http.client io.streams.string kernel init +namespaces prettyprint smtp arrays sequences math math.parser +strings sets ; +IN: site-watcher + +SYMBOL: sites + +SYMBOL: site-watcher-from + +sites [ H{ } clone ] initialize + +TUPLE: watching emails url last-up up? send-email? error ; + + ( emails url -- watching ) + watching new + swap >>url + swap ?1array >>emails + now >>last-up + t >>up? ; + +ERROR: not-watching-site url status ; + +: set-site-flags ( watching new-up? -- watching ) + [ over up?>> = [ t >>send-email? ] unless ] keep >>up? ; + +: site-bad ( watching error -- ) + >>error f set-site-flags drop ; + +: site-good ( watching -- ) + f >>error + t set-site-flags + now >>last-up drop ; + +: check-sites ( assoc -- ) + [ + swap '[ _ http-get 2drop site-good ] [ site-bad ] recover + ] assoc-each ; + +: site-up-email ( email watching -- email ) + last-up>> now swap time- duration>minutes 60 /mod + [ >integer number>string ] bi@ + [ " hours, " append ] [ " minutes" append ] bi* append + "Site was down for (at least): " prepend >>body ; + +: ?unparse ( string/object -- string ) + dup string? [ unparse ] unless ; inline + +: site-down-email ( email watching -- email ) + error>> ?unparse >>body ; + +: send-report ( watching -- ) + [ ] dip + { + [ emails>> >>to ] + [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ] + [ dup up?>> [ site-up-email ] [ site-down-email ] if ] + [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ] + [ f >>send-email? drop ] + } cleave send-email ; + +: report-sites ( assoc -- ) + [ nip send-email?>> ] assoc-filter + [ nip send-report ] assoc-each ; + +PRIVATE> + +SYMBOL: site-watcher-frequency +site-watcher-frequency [ 5 minutes ] initialize + +: watch-sites ( assoc -- alarm ) + '[ + _ [ check-sites ] [ report-sites ] bi + ] site-watcher-frequency get every ; + +: watch-site ( emails url -- ) + sites get ?at [ + [ [ ?1array ] dip append prune ] change-emails drop + ] [ + dup url>> sites get set-at + ] if ; + +: delete-site ( url -- ) + sites get delete-at ; + +: unwatch-site ( emails url -- ) + [ ?1array ] dip + sites get ?at [ + [ diff ] change-emails dup emails>> empty? [ + url>> delete-site + ] [ + drop + ] if + ] [ + nip delete-site + ] if ; + +SYMBOL: running-site-watcher + +: run-site-watcher ( -- ) + running-site-watcher get-global [ + sites get-global watch-sites running-site-watcher set-global + ] unless ; + +[ f running-site-watcher set-global ] "site-watcher" add-init-hook + +MAIN: run-site-watcher From 89e6ea1bbeb39f69464154214a28821bf9c49994 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 11:59:18 -0500 Subject: [PATCH 04/11] add tutorial for setting up smtp to work with gmail --- basis/smtp/smtp-docs.factor | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor index 8e34411604..453f4009e2 100644 --- a/basis/smtp/smtp-docs.factor +++ b/basis/smtp/smtp-docs.factor @@ -73,6 +73,20 @@ HELP: send-email } } ; +ARTICLE: "smtp-gmail" "Setting up SMTP with gmail" +"If you plan to send all email from the same address, then setting variables in the global namespace is the best option. The code example below does this approach and is meant to go in your " { $link "factor-boot-rc" } "." $nl +"Several variables need to be set for sending outgoing mail through gmail. First, we set the login and password to a " { $link } " tuple with our login. Next, we set the gmail server address with an " { $link } " object. Finally, we tell the SMTP library to use a secure connection." +{ $code + "USING: smtp namespaces io.sockets ;" + "" + "\"my.gmail.address@gmail.com\" \"secret-password\" smtp-auth set-global" + "" + "\"smtp.gmail.com\" 587 smtp-server set-global" + "" + "t smtp-tls? set-global" +} ; + + ARTICLE: "smtp" "SMTP client library" "The " { $vocab-link "smtp" } " vocabulary sends e-mail via an SMTP server." $nl @@ -89,6 +103,8 @@ $nl { $subsection email } { $subsection } "Sending an email:" -{ $subsection send-email } ; +{ $subsection send-email } +"More topics:" +{ $subsection "smtp-gmail" } ; ABOUT: "smtp" From 07d906086d87c69087012eadf002c168e9576092 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 13:58:08 -0500 Subject: [PATCH 05/11] docs updates for calendar --- basis/calendar/calendar-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 433459cb24..3aae10f6a7 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -36,7 +36,7 @@ HELP: month-name { $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ; HELP: month-abbreviations -{ $values { "array" array } } +{ $values { "value" array } } { $description "Returns an array with the English abbreviated names of all the months." } { $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ; @@ -54,7 +54,7 @@ HELP: day-name { $description "Looks up the day name and returns it as a string." } ; HELP: day-abbreviations2 -{ $values { "array" array } } +{ $values { "value" array } } { $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ; HELP: day-abbreviation2 @@ -62,7 +62,7 @@ HELP: day-abbreviation2 { $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ; HELP: day-abbreviations3 -{ $values { "array" array } } +{ $values { "value" array } } { $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ; HELP: day-abbreviation3 From cdec85dc8f35ba2040db6c3488bc8206dbda7641 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 14:48:28 -0500 Subject: [PATCH 06/11] write out bitmaps from arbitrary image tuples --- basis/images/bitmap/bitmap.factor | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index cf16df7d82..64de5a734f 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -130,28 +130,30 @@ MACRO: (nbits>bitmap) ( bits -- ) PRIVATE> -: save-bitmap ( bitmap path -- ) +: bitmap>color-index ( bitmap-array -- byte-array ) + 4 [ 3 head-slice reverse ] map B{ } join ; inline + +: save-bitmap ( image path -- ) binary [ B{ CHAR: B CHAR: M } write [ - color-index>> length 14 + 40 + write4 + bitmap>> bitmap>color-index length 14 + 40 + write4 0 write4 54 write4 40 write4 ] [ { - [ width>> write4 ] - [ height>> write4 ] - [ planes>> 1 or write2 ] - [ bit-count>> 24 or write2 ] - [ compression>> 0 or write4 ] - [ size-image>> write4 ] - [ x-pels>> 0 or write4 ] - [ y-pels>> 0 or write4 ] - [ color-used>> 0 or write4 ] - [ color-important>> 0 or write4 ] - [ rgb-quads>> write ] - [ color-index>> write ] + [ dim>> first2 [ write4 ] bi@ ] + [ drop 1 write2 ] + [ drop 24 write2 ] + [ drop 0 write4 ] + [ bitmap>> bitmap>color-index length write4 ] + [ drop 0 write4 ] + [ drop 0 write4 ] + [ drop 0 write4 ] + [ drop 0 write4 ] + ! rgb-quads + [ bitmap>> bitmap>color-index write ] } cleave ] bi ] with-file-writer ; From 8ac5834861a0861d3347a98e0dbdba360336a134 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 15:08:50 -0500 Subject: [PATCH 07/11] cleaning up bitmaps --- basis/images/bitmap/bitmap.factor | 51 ++++++++++++++++++++----------- 1 file changed, 34 insertions(+), 17 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 64de5a734f..c75dddd626 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -6,11 +6,13 @@ kernel macros math math.bitwise math.functions namespaces sequences strings images endian summary ; IN: images.bitmap -TUPLE: bitmap-image < image +TUPLE: loading-bitmap magic size reserved offset header-length width height planes bit-count compression size-image x-pels y-pels color-used color-important rgb-quads color-index ; +TUPLE: bitmap-image < image ; + ! Currently can only handle 24/32bit bitmaps. ! Handles row-reversed bitmaps (their height is negative) @@ -30,7 +32,7 @@ M: bitmap-magic summary ERROR: bmp-not-supported n ; -: raw-bitmap>buffer ( bitmap -- array ) +: raw-bitmap>seq ( bitmap -- array ) dup bit-count>> { { 32 [ color-index>> ] } @@ -64,10 +66,10 @@ ERROR: bmp-not-supported n ; read4 >>color-used read4 >>color-important ; -: rgb-quads-length ( bitmap -- n ) +: rgb-quads-length ( loading-bitmap -- n ) [ offset>> 14 - ] [ header-length>> ] bi - ; -: color-index-length ( bitmap -- n ) +: color-index-length ( loading-bitmap -- n ) { [ width>> ] [ planes>> * ] @@ -79,14 +81,11 @@ ERROR: bmp-not-supported n ; dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index ; -: load-bitmap-data ( path bitmap -- bitmap ) +: load-bitmap-data ( path loading-bitmap -- loading-bitmap ) [ binary ] dip '[ _ parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader ; -: process-bitmap-data ( bitmap -- bitmap ) - dup raw-bitmap>buffer >>bitmap ; - ERROR: unknown-component-order bitmap ; : bitmap>component-order ( bitmap -- object ) @@ -97,26 +96,26 @@ ERROR: unknown-component-order bitmap ; [ unknown-component-order ] } case ; -: fill-image-slots ( bitmap -- bitmap ) - dup { +: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image ) + [ bitmap-image new ] dip + { + [ raw-bitmap>seq >>bitmap ] [ [ width>> ] [ height>> ] bi 2array >>dim ] [ bitmap>component-order >>component-order ] - [ bitmap>> >>bitmap ] } cleave ; -M: bitmap-image load-image* ( path bitmap -- bitmap ) - load-bitmap-data process-bitmap-data - fill-image-slots ; +M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) + drop loading-bitmap new + load-bitmap-data loading-bitmap>bitmap-image ; MACRO: (nbits>bitmap) ( bits -- ) [ -3 shift ] keep '[ - bitmap-image new + loading-bitmap new 2over * _ * >>size-image swap >>height swap >>width swap array-copy [ >>bitmap ] [ >>color-index ] bi - _ >>bit-count fill-image-slots - t >>upside-down? + _ >>bit-count ] ; : bgr>bitmap ( array height width -- bitmap ) @@ -143,15 +142,33 @@ PRIVATE> 40 write4 ] [ { + ! width height [ dim>> first2 [ write4 ] bi@ ] + + ! planes [ drop 1 write2 ] + + ! bit-count [ drop 24 write2 ] + + ! compression [ drop 0 write4 ] + + ! size-image [ bitmap>> bitmap>color-index length write4 ] + + ! x-pels [ drop 0 write4 ] + + ! y-pels [ drop 0 write4 ] + + ! color-used [ drop 0 write4 ] + + ! color-important [ drop 0 write4 ] + ! rgb-quads [ bitmap>> bitmap>color-index write ] } cleave From aa91df6b10d385ea0356f65ba53a2b5a114de059 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 15:17:51 -0500 Subject: [PATCH 08/11] more bitmap cleanup --- basis/images/bitmap/bitmap.factor | 48 +++++++++---------------------- 1 file changed, 14 insertions(+), 34 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index c75dddd626..dfa2d7f4bf 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -6,16 +6,21 @@ kernel macros math math.bitwise math.functions namespaces sequences strings images endian summary ; IN: images.bitmap +: assert-sequence= ( a b -- ) + 2dup sequence= [ 2drop ] [ assert ] if ; + +: read2 ( -- n ) 2 read le> ; +: read4 ( -- n ) 4 read le> ; + +TUPLE: bitmap-image < image ; + +! Used to construct the final bitmap-image + TUPLE: loading-bitmap magic size reserved offset header-length width height planes bit-count compression size-image x-pels y-pels color-used color-important rgb-quads color-index ; -TUPLE: bitmap-image < image ; - -! Currently can only handle 24/32bit bitmaps. -! Handles row-reversed bitmaps (their height is negative) - ERROR: bitmap-magic magic ; M: bitmap-magic summary @@ -23,9 +28,6 @@ M: bitmap-magic summary > abs memory>byte-array ; - : 8bit>buffer ( bitmap -- array ) [ rgb-quads>> 4 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; @@ -37,18 +39,12 @@ ERROR: bmp-not-supported n ; { { 32 [ color-index>> ] } { 24 [ color-index>> ] } - { 16 [ bmp-not-supported ] } { 8 [ 8bit>buffer ] } - { 4 [ bmp-not-supported ] } - { 2 [ bmp-not-supported ] } - { 1 [ bmp-not-supported ] } + [ bmp-not-supported ] } case >byte-array ; -: read2 ( -- n ) 2 read le> ; -: read4 ( -- n ) 4 read le> ; - : parse-file-header ( bitmap -- bitmap ) - 2 read dup "BM" sequence= [ bitmap-magic ] unless >>magic + 2 read "BM" assert-sequence= read4 >>size read4 >>reserved read4 >>offset ; @@ -77,7 +73,7 @@ ERROR: bmp-not-supported n ; [ height>> abs * ] } cleave ; -: parse-bitmap ( bitmap -- bitmap ) +: parse-bitmap ( loading-bitmap -- loading-bitmap ) dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index ; @@ -108,29 +104,13 @@ M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) drop loading-bitmap new load-bitmap-data loading-bitmap>bitmap-image ; -MACRO: (nbits>bitmap) ( bits -- ) - [ -3 shift ] keep '[ - loading-bitmap new - 2over * _ * >>size-image - swap >>height - swap >>width - swap array-copy [ >>bitmap ] [ >>color-index ] bi - _ >>bit-count - ] ; - -: bgr>bitmap ( array height width -- bitmap ) - 24 (nbits>bitmap) ; - -: bgra>bitmap ( array height width -- bitmap ) - 32 (nbits>bitmap) ; - : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; PRIVATE> : bitmap>color-index ( bitmap-array -- byte-array ) - 4 [ 3 head-slice reverse ] map B{ } join ; inline + 4 [ 3 head-slice ] map B{ } join ; inline : save-bitmap ( image path -- ) binary [ From 935849b418542ae001b1eb10f170d6029b39e812 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 15:31:59 -0500 Subject: [PATCH 09/11] fix bitmap rendering --- basis/images/bitmap/bitmap.factor | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index dfa2d7f4bf..db3f1c93da 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -11,6 +11,8 @@ IN: images.bitmap : read2 ( -- n ) 2 read le> ; : read4 ( -- n ) 4 read le> ; +: write2 ( n -- ) 2 >le write ; +: write4 ( n -- ) 4 >le write ; TUPLE: bitmap-image < image ; @@ -34,22 +36,25 @@ M: bitmap-magic summary ERROR: bmp-not-supported n ; -: raw-bitmap>seq ( bitmap -- array ) +: reverse-lines ( byte-array width -- byte-array ) + 3 * concat ; inline + +: raw-bitmap>seq ( loading-bitmap -- array ) dup bit-count>> { { 32 [ color-index>> ] } - { 24 [ color-index>> ] } - { 8 [ 8bit>buffer ] } + { 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] } + { 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] } [ bmp-not-supported ] } case >byte-array ; -: parse-file-header ( bitmap -- bitmap ) +: parse-file-header ( loading-bitmap -- loading-bitmap ) 2 read "BM" assert-sequence= read4 >>size read4 >>reserved read4 >>offset ; -: parse-bitmap-header ( bitmap -- bitmap ) +: parse-bitmap-header ( loading-bitmap -- loading-bitmap ) read4 >>header-length read4 >>width read4 >>height @@ -84,7 +89,7 @@ ERROR: bmp-not-supported n ; ERROR: unknown-component-order bitmap ; -: bitmap>component-order ( bitmap -- object ) +: bitmap>component-order ( loading-bitmap -- object ) bit-count>> { { 32 [ BGRA ] } { 24 [ BGR ] } @@ -102,10 +107,8 @@ ERROR: unknown-component-order bitmap ; M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) drop loading-bitmap new - load-bitmap-data loading-bitmap>bitmap-image ; - -: write2 ( n -- ) 2 >le write ; -: write4 ( n -- ) 4 >le write ; + load-bitmap-data + loading-bitmap>bitmap-image ; PRIVATE> @@ -150,7 +153,10 @@ PRIVATE> [ drop 0 write4 ] ! rgb-quads - [ bitmap>> bitmap>color-index write ] + [ + [ bitmap>> bitmap>color-index ] [ dim>> first ] bi + reverse-lines write + ] } cleave ] bi ] with-file-writer ; From f8da7967fcb933ca6b02cf20989a8dcec0d18766 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 15:52:04 -0500 Subject: [PATCH 10/11] remove unused slot --- basis/images/bitmap/bitmap.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index db3f1c93da..a59d276d7f 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays byte-arrays columns combinators fry grouping io io.binary io.encodings.binary io.files kernel macros math math.bitwise math.functions namespaces sequences -strings images endian summary ; +strings images endian summary bitstreams ; IN: images.bitmap : assert-sequence= ( a b -- ) @@ -19,7 +19,7 @@ TUPLE: bitmap-image < image ; ! Used to construct the final bitmap-image TUPLE: loading-bitmap -magic size reserved offset header-length width +size reserved offset header-length width height planes bit-count compression size-image x-pels y-pels color-used color-important rgb-quads color-index ; From 845158fffd25d1fbc127d9dcc6a447d83461e3fb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 14 Mar 2009 15:52:25 -0500 Subject: [PATCH 11/11] fix using --- basis/images/bitmap/bitmap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index a59d276d7f..1ba18f56a5 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types arrays byte-arrays columns combinators fry grouping io io.binary io.encodings.binary io.files kernel macros math math.bitwise math.functions namespaces sequences -strings images endian summary bitstreams ; +strings images endian summary ; IN: images.bitmap : assert-sequence= ( a b -- )