Keith Vetter 2010-09-10 -- Mormon Porn or Nude Bubbling was created by UltimusMormon on the BodyBuilding.com forum. He states "Being mormon, I can't look at porn or nudity. So I have to get creative. That's why I invented 'bubbling' ".
The basic idea is to take an image of a woman with lots of bare skin, create a bunch of 'bubbles' on top of the bare skin and turn that into an image mask where only the bubbles are transparent. The effect is that your imagination turns an innocent, albeit racy image into a seemingly nude, pornographic picture. You don't see any naughty bits, but your mind imagines them.
For more info check out http://nudebubbling.com/ and http://bubbler.heroku.com/index.html .
The fun for me was solving the technical challenges, like how to you create transparent bubbles in a tk image? I had to write a primitive circle drawing routing. Also, I wanted have the program to be more interactive, creating and displaying the mask in real time, but I couldn't get it done fast enough.
##+##########################################################################
#
# mormonPorn
# by Keith Vetter, Sept 8, 2010
#
package require Tk
package require Img
package require http
set S(fname) ""
set S(transparent) 0
set B1 {
bubbleInside yellow
bubbleEdge black
mask yellow
width 0
width2 2
}
set B2 {
bubbleInside {}
bubbleEdge magenta
mask yellow
width 4
width2 4
}
array set B $B1
proc DoDisplay {} {
global S
wm title . "Mormon Porn"
bind all <F2> {console show}
menu .m -tearoff 0
. configure -menu .m
menu .m.file -tearoff 0
menu .m.bubble -tearoff 0
menu .m.help -tearoff 0
.m add cascade -label "File" -menu .m.file -underline 0
.m add cascade -label "Bubble" -menu .m.bubble -underline 0
.m add cascade -label "Help" -menu .m.help -underline 0
.m.file add command -label "Restart" -command Restart -underline 0
.m.file add command -label "Open File" -command "Open file" -under 0
.m.file add command -label "Open URL" -command "Open url" -under 5
.m.file add command -label "Save" -command "Save" -under 0
.m.file add separator
.m.file add command -label "Exit" -command exit -under 1
.m.bubble add checkbutton -label "Transparent bubbles" \
-underline 0 -variable ::S(transparent) -command ToggleTransparent
.m.help add command -label "Demo" -command Demo -under 0
.m.help add command -label "About" -command About -under 0
::ttk::frame .buttons
::ttk::button .mask -text "Make Mask" -command MakeMask
::ttk::frame .f -borderwidth 2 -relief ridge
canvas .c -width 400 -height 600 -highlightthickness 0 -bd 0 -bg cyan
bind .c <1> [list Button1 down %x %y]
bind .c <B1-Motion> [list Button1 move %x %y]
bind .c <ButtonRelease-1> [list Button1 up %x %y]
bind .c <2> [list Button2 down %x %y]
bind .c <B2-Motion> [list Button2 move %x %y]
bind .c <ButtonRelease-2> [list Button2 up %x %y]
bind .c <3> [list Button3 down %x %y]
::ttk::frame .f2 -borderwidth 2 -relief ridge
canvas .c2 -width 400 -height 600 -highlightthickness 0 -bd 0 -bg cyan
pack .buttons -side bottom -fill x
pack .mask -in .buttons -side left -pady .2in -expand 1
pack .f -side left -fill both -expand 1
pack .c -in .f -side left -fill both -expand 1
pack .f2 -side left -fill both -expand 1
pack .c2 -in .f2 -side left -fill both -expand 1
}
##+##########################################################################
#
# NewBubbleImage -- Starts a new image to be bubbled
#
proc NewBubbleImage {fname} {
global S BITMAP
unset -nocomplain BITMAP
foreach img [image names] { image delete $img }
.c delete all
.c2 delete all
set img [NewImage $fname]
set S(all) {}
.c config -width $S(w) -height $S(h)
.c2 config -width $S(w) -height $S(h)
.c create image 0 0 -tag img -image $img -anchor nw
.c2 create image 0 0 -tag img -image $img -anchor nw
}
##+##########################################################################
#
# Restart -- Erases all bubbles
#
proc Restart {} {
global S
.c delete bubble
set S(all) {}
}
##+##########################################################################
#
# Open -- Gets new image filename or url
#
proc Open {what} {
set fname [GetURLorFile $what]
if {$fname eq ""} return
NewBubbleImage $fname
}
##+##########################################################################
#
# Save -- Saves our bubble image
#
proc Save {} {
set types {{"JPEG files" {.jpg}} {"All Files" *}}
set fname [tk_getSaveFile -title "Mormon Porn Save File" \
-defaultextension .jpg \
-initialdir [file dirname $::S(fname)] \
-filetypes $types]
if {$fname eq ""} return
image create photo ::img::save
::img::save copy ::img::p
if {"::img::mask" in [image names]} {
::img::save copy ::img::mask
}
::img::save write $fname -format jpeg
image delete ::img::save
tk_messageBox -message "Saved $fname"
}
##+##########################################################################
#
# GetURLorFile -- Puts up either the stock getOpenFile dialog or custom
# getUrl dialog, and returns either the filename or url
#
proc GetURLorFile {what} {
global S
if {$what eq "file"} {
set types {{"Image files" {.gif .jpg .png}} {"All Files" *}}
set fname [tk_getOpenFile -title "Mormon Porn Open File" \
-initialdir [file dirname $S(fname)] \
-initialfile [file tail $S(fname)] \
-filetypes $types]
} else {
set save $::S(url)
destroy .ux
toplevel .ux
wm title .ux "Mormon Porn Get URI"
wm protocol .ux WM_DELETE_WINDOW {set ::S(url) ""; destroy .ux}
set x [expr {[winfo x .] + 50}]
set y [expr {[winfo y .] + 50}]
wm geom .ux "+$x+$y"
::ttk::frame .ux.u
::ttk::label .ux.u.l -text "Enter URL"
::ttk::entry .ux.u.e -textvariable ::S(url) -width 30
::ttk::frame .ux.u.buttons
::ttk::button .ux.u.buttons.go -text "Open" -command {destroy .ux}
::ttk::button .ux.u.buttons.cancel -text "Cancel" \
-command {set ::S(url) ""; destroy .ux}
pack .ux.u -fill both -expand 1 -padx .1in -pady {.1in 0}
grid .ux.u.l -sticky w
grid .ux.u.e -sticky ns
grid .ux.u.buttons -pady .1in -sticky news
pack .ux.u.buttons.go .ux.u.buttons.cancel -side left -expand 1
focus .ux.u.e
.ux.u.e selection range 0 end
.ux.u.e icursor end
tkwait window .ux
set fname $::S(url)
if {$::S(url) eq ""} { set ::S(url) $save }
}
return $fname
}
##+##########################################################################
#
# MakeBubble -- Creates a bubble on the screen
#
proc MakeBubble {xy} {
global B
set tag [.c create oval $xy \
-fill $B(bubbleInside) \
-outline $B(bubbleEdge) \
-width $B(width) \
-tag bubble]
return $tag
}
##+##########################################################################
#
# Button1 -- Handles creating and sizing a bubble
#
proc Button1 {verb x y} {
global S B
if {$verb eq "down"} {
set S(cx) $x
set S(cy) $y
set xy [Box $x $y $x $y]
set S(tag) [MakeBubble $xy]
} elseif {$verb eq "move"} {
set xy [Box $S(cx) $S(cy) $x $y]
.c coords $S(tag) $xy
set S(last) [list $x $y]
} elseif {$verb eq "up"} {
lappend S(all) [list $S(tag) $S(cx) $S(cy) $S(radius)]
}
}
##+##########################################################################
#
# Button2 -- Handles dragging a bubble around the screen
#
proc Button2 {verb x y} {
global S B
if {$verb eq "down"} {
set S(who) [FindBubble $x $y]
if {$S(who) == -1} return
set id [lindex $S(all) $S(who) 0]
.c itemconfig $id -width $B(width2)
.c config -cursor fleur
set S(cx) $x
set S(cy) $y
} elseif {$verb eq "move"} {
if {$S(who) == -1} return
set dx [expr {$x - $S(cx)}]
set dy [expr {$y - $S(cy)}]
if {$dx == 0 && $dy == 0} return
set id [lindex $S(all) $S(who) 0]
.c move $id $dx $dy
lassign [lindex $S(all) $S(who)] . cx cy
incr cx $dx
incr cy $dy
set S(cx) $x
set S(cy) $y
lset S(all) $S(who) 1 $cx
lset S(all) $S(who) 2 $cy
} elseif {$verb eq "up"} {
if {$S(who) == -1} return
set id [lindex $S(all) $S(who) 0]
.c itemconfig $id -width $B(width)
.c config -cursor {}
}
}
##+##########################################################################
#
# Button3 -- Handles deleting a bubble
#
proc Button3 {verb x y} {
global S
set idx [FindBubble $x $y]
if {$idx == -1} return
set id [lindex $S(all) $idx 0]
.c delete $id
set S(all) [lreplace $S(all) $idx $idx]
}
##+##########################################################################
#
# FindBubble -- Searches all bubbles in S(all) and return index of the last one
# which overlaps a given point
#
proc FindBubble {x y} {
global S
for {set i [expr {[llength $S(all)] - 1}]} {$i >= 0} {incr i -1} {
lassign [lindex $S(all) $i] id cx cy radius
if {hypot($cx-$x,$cy-$y) <= $radius} {
return $i
}
}
return -1
}
##+##########################################################################
#
# Box -- Given center and point on edge, returns bbox for our bubble
#
proc Box {cx cy x y} {
set radius [expr {round(hypot($x-$cx,$y-$cy))}]
if {$radius < 2} { set radius 2}
set ::S(radius) $radius
set x0 [expr {$cx-$radius}]
set y0 [expr {$cy-$radius}]
set x1 [expr {$cx+$radius}]
set y1 [expr {$cy+$radius}]
return [list $x0 $y0 $x1 $y1]
}
##+##########################################################################
#
# MakeMask -- Creates our bubble mask by hand drawing filled circles into
# an offscreen bitmap, then setting all empty bits to a mask color--leaving
# on bits undefined/transparent
#
proc MakeMask {{clr ""}} {
global S BITMAP B
unset -nocomplain BITMAP
if {$clr eq ""} { set clr $B(mask) }
foreach bubble $S(all) {
MakeCircleMask {*}$bubble
}
set start [clock seconds]
::img::mask blank
.c2 create image 0 0 -tag mask -image ::img::mask -anchor nw
for {set y 0} {$y < $S(h)} {incr y} {
set y1 [expr {$y+1}]
update
set off 1
set BITMAP($S(w),$y) 1 ;# Sentinel
for {set x 0} {$x <= $S(w)} {incr x} {
if {! [info exists BITMAP($x,$y)]} { ;# Pixel that needs masking
if {$off} { set off 0; set left $x}
} else { ;# Pixel that needs transparency
if {! $off} {
set off 1
::img::mask put $clr -to $left $y $x $y1
}
}
}
if {! $off} { puts "bad off: $y" ; return}
}
set end [clock seconds]
puts "[expr {$end-$start}] seconds"
}
##+##########################################################################
#
# MakeCircleMask -- "Draws" a circle into a bitmap
# see http://www.cs.unc.edu/~mcmillan/comp136/Lecture7/circle.html
#
proc MakeCircleMask {tag cx cy r} {
set x 0
set y $r
set p [expr {(5 - $r*4)/4.0}]
_ExploitSymmetry $cx $cy $x $y
while {$x < $y} {
incr x
if {$p < 0} {
set p [expr {$p + 2*$x + 1}]
} else {
incr y -1
set p [expr {$p + 2*($x-$y)+1}]
}
_ExploitSymmetry $cx $cy $x $y
}
}
##+##########################################################################
#
# _ExploitSymmetry -- Uses symmetry to reflect known edge point around the circle
#
proc _ExploitSymmetry {cx cy x y} {
if {$x == 0} {
_Line [expr {$cx+$y}] $cy [expr {$cx-$y}] $cy
} elseif {$x == $y} {
_Line [expr {$cx + $x}] [expr {$cy + $y}] [expr {$cx - $x}] [expr {$cy + $y}]
_Line [expr {$cx + $x}] [expr {$cy - $y}] [expr {$cx - $x}] [expr {$cy - $y}]
} elseif {$x < $y} {
_Line [expr {$cx + $x}] [expr {$cy + $y}] [expr {$cx - $x}] [expr {$cy + $y}]
_Line [expr {$cx + $x}] [expr {$cy - $y}] [expr {$cx - $x}] [expr {$cy - $y}]
_Line [expr {$cx + $y}] [expr {$cy + $x}] [expr {$cx - $y}] [expr {$cy + $x}]
_Line [expr {$cx + $y}] [expr {$cy - $x}] [expr {$cx - $y}] [expr {$cy - $x}]
}
}
##+##########################################################################
#
# _Line -- Fills in all bits on line between x0,y and x1,y
#
proc _Line {x0 y0 x1 y1} {
global BITMAP S
# ASSERTION: $y0 == $y1
if {$y0 < 0 || $y0 >= $S(h)} return
set lo [expr {max(min($x0,$x1),0)}]
set hi [expr {min(max($x0,$x1),$S(w)-1)}]
for {set x $lo} {$x <= $hi} {incr x} {
set BITMAP($x,$y0) 1
}
#.c create line $x0 $y0 $x1 $y1 -fill cyan
}
##+##########################################################################
#
# Demo -- Does a quick demo using canned bubbles on a stock image
#
proc Demo {} {
global demo
set demo(who) [expr {($demo(who) + 1) % [llength [array names demo *,url]]}]
if {$::S(proto) eq "http" && $::S(url) eq $demo($demo(who),url)} {
Restart
} else {
NewBubbleImage $demo($demo(who),url)
}
foreach bubble $demo($demo(who),bubbles) {
lassign $bubble tag cx cy r
set x [expr {$cx + $r}]
set y $cy
set xy [Box $cx $cy $x $y]
set tag [MakeBubble $xy]
lappend ::S(all) [list $tag $cx $cy $::S(radius)]
}
MakeMask
}
##+##########################################################################
#
# About -- Our about and help dialog
#
proc About {} {
destroy .about
toplevel .about
wm title .about "About Mormon Porn"
wm geom .about "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"
text .about.t -relief raised -wrap word -width 70 -height 24
.about.t config -padx 10 -pady 10
button .about.dismiss -text Dismiss -command {destroy .about}
pack .about.dismiss -side bottom -pady 10
pack .about.t -side top -expand 1 -fill both
set bold "[font actual [.about.t cget -font]] -weight bold"
set italic "[font actual [.about.t cget -font]] -slant italic"
.about.t tag configure title -justify center -foreground red \
-font "Times 20 bold"
.about.t tag configure title2 -justify center -font "Times 12 bold"
.about.t tag configure bold -font $bold
.about.t tag configure quote -font $italic
.about.t tag configure n -lmargin1 15 -lmargin2 15
.about.t insert end "Mormon Porn / Nude Bubbling\n" title "by Keith Vetter\n\n" title2
.about.t insert end "Mormon Porn was created by UltimusMormon "
.about.t insert end "on the BodyBuilding.com forum. He states \""
.about.t insert end "Being mormon, I can't look at porn or nudity. " quote
.about.t insert end "So I have to get creative. That's why I " quote
.about.t insert end "invented 'bubbling'" quote "\".\n\n"
set msg "The basic idea is to take an image of a woman with "
append msg "lots of bare skin, create a bunch of 'bubbles' "
append msg "on top of the bare skin and turn that into an image mask where "
append msg "only the bubbles are transparent.\n\n"
.about.t insert end $msg
set msg "The effect is that your imagination turns an innocent, "
append msg "albeit racy image "
append msg "into a seemingly nude, pornographic picture. "
append msg "You don't see any naughty bits, but your mind imagines them.\n\n"
.about.t insert end $msg
.about.t insert end "For more info check out "
.about.t insert end "http://nudebubbling.com/" bold " and "
.about.t insert end "http://bubbler.heroku.com/index.html" bold ".\n\n"
.about.t insert end "HOW TO USE\n" bold
.about.t insert end "o" n " Create bubble: click and drag\n"
.about.t insert end "o" n " Move bubble: click and drag middle button\n"
.about.t insert end "o" n " Delete bubble: click right button\n"
.about.t config -state disabled
}
##+##########################################################################
#
# NewImage -- Creates a new image from a filename or url
#
proc NewImage {fname} {
global S
if {[file exists $fname]} {
set ::S(fname) $fname
set ::S(proto) file
set img [image create photo ::img::p -file $fname]
set S(w) [image width $img]
set S(h) [image height $img]
image create photo ::img::mask -width $S(w) -height $S(h)
return $img
}
if {[string match "http:*" $fname]} {
set token [http::geturl $fname]
::http::wait $token
set code [::http::code $token]
set ncode [::http::ncode $token]
set data [::http::data $token] ; list
::http::cleanup $token
if {$ncode != 200} { error "Can't download $fname\n$code" }
set n [catch { set img [image create photo ::img::p -data $data] } emsg]
if {$n} {error "Not an image: $fname"}
set ::S(url) $fname
set ::S(proto) http
set S(w) [image width $img]
set S(h) [image height $img]
image create photo ::img::mask -width $S(w) -height $S(h)
return $img
}
error "can't find $fname"
}
##+##########################################################################
#
# ToggleTransparent -- As the name says
#
proc ToggleTransparent {} {
global S B
puts "S(transparent): $S(transparent)"
if {$S(transparent)} {
array set B $::B2
} else {
array set B $::B1
}
.c itemconfig bubble -width $B(width) -fill $B(bubbleInside) -outline $B(bubbleEdge)
}
################################################################
set demo(who) -1
set demo(0,url) {http://upload.wikimedia.org/wikipedia/commons/thumb/5/50/Lovely_model_-_Tricia_from_Singapore_-Bikini.jpg/400px-Lovely_model_-_Tricia_from_Singapore_-Bikini.jpg}
set demo(0,bubbles) {{bubble0 191 90 82} {bubble1 310 175 53} {bubble6 209 300 70} {bubble9 311 450 81} {bubble12 43 391 47} {bubble13 54 118 47} {bubble14 57 530 52} {bubble15 81 255 41} {bubble16 142 206 30} {bubble18 186 469 49}}
set demo(1,url) http://lh5.ggpht.com/_D8FfQDqFKYI/SsNN2pCfBvI/AAAAAAAAACs/Iw_Fo-JKkd4/s640/bikini_skirt01.jpg
set demo(1,bubbles) {{3 144 93 93} {4 277 165 50} {5 390 358 79} {6 154 435 79} {8 154 279 37} {9 36 282 49} {10 307 535 65}}
set demo(2,url) http://upload.wikimedia.org/wikipedia/commons/thumb/2/26/Christy_Marie_as_Slave_Leia.jpg/398px-Christy_Marie_as_Slave_Leia.jpg
set demo(2,bubbles) {{14 134 51 124} {15 332 169 70} {16 340 340 42} {19 207 418 61} {20 336 519 59} {21 80 546 64} {22 83 404 43} {23 101 220 43}}
DoDisplay
NewBubbleImage $demo(0,url)
return