! ! Tweening, Warping and Morphing of `images' in Fortran 90 ! ! This is a series of modules that implement image Morphing. ! Morphing actually uses techniques called Tweening and Warping ! so modules are also provided for these. This software was ! developed as an experiment ... it is not guaranteed to be ! complete, error tolerant, efficient, great Fortran 90 or ! useful ...... ! ! The file also contains a test program and some test data ! ! Copyright: Robert M J Iles, Oxford UK, 1994 o_o ! No Warranty, Explicit or Applied =( )= ! Version 1.0 (incomplete) Mar94 U !--------------------------------------------------------------- ! Modules ! Morph_Types Definitions for point, colour, line, pixel etc ! Tweens Provides tweening capabilities ! Warp_code Warping capabilities !=============================================================== ! ! Basic types on which you might want to operate ...... ! Module Morph_Types type point ! A point in x,y space integer :: x integer :: y end type point type colour ! An RGB colour value integer :: r integer :: g integer :: b end type colour type pixel ! A colour pixel (with position and colour values) type(point) :: pos type(colour):: rgb end type pixel type line ! A coloured line type(point) :: start type(point) :: end type(colour):: rgb end type line type pixmap ! A rectangular pixmap integer :: height integer :: width type(colour),pointer :: map(:,:) end type pixmap end module Morph_Types ! ! Tweening - This is the operation of calculating something that ! is between a start point and an end point, hence ! betweening ... `tweening ... Tweening ! ! The argument `frac' is the fraction the result should ! be between from (frac=0.0) and to (frac=1.0) ! Module Tweens use Morph_Types contains function tween_pixel(from,to,frac) result(res) type(pixel) :: from, to, res real :: frac res%rgb%r = from%rgb%r + (to%rgb%r - from%rgb%r) * frac res%rgb%g = from%rgb%g + (to%rgb%g - from%rgb%g) * frac res%rgb%b = from%rgb%b + (to%rgb%b - from%rgb%b) * frac end function tween_pixel function tween_point(from,to,frac) result(res) type(point) :: from, to, res real :: frac res%x = from%x + (to%x - from%x) * frac res%y = from%y + (to%y - from%y) * frac end function tween_point function tween_line(from,to,frac) result(res) type(line) :: from, to, res real :: frac res%start = tween_point(from%start,to%start,frac) res%end = tween_point(from%end,to%end,frac) end function tween_line function tween_points(from,to,frac) result(res) type(point) :: from(:), to(:) type(point) :: res(size(from)) real :: frac do i = 1, size(from) res(i)=tween_point(from(i),to(i),frac) enddo end function tween_points function tween_lines(from,to,frac) result(res) type(line) :: from(:), to(:), res(size(from)) real :: frac do i = 1, size(from) res(i)=tween_line(from(i),to(i),frac) enddo end function tween_lines function tween_pixmap(from,to,frac) result(res) type(pixel) :: from(:,:), to(:,:), res(size(from,1),size(from,2)) real :: frac do i = 1, size(from,1) do j = 1, size(from,2) res(i,j)=tween_pixel(from(i,j),to(i,j),frac) enddo enddo end function tween_pixmap end module Tweens ! ! This module does Warping and Morphing ! ! warp - Take a source image (source) and produce a destination ! image (dest) by `stretching' a series of lines on the ! image (from) to new places(to). ! Define some lines on the source image, each defined by ! its start and end points. For each line, define where ! it should appear on the destination image ..... each ! pixel of the source is then warped under the influence ! of these lines as if the image were drawn on a rubber ! sheet and the lines were then physically stretched to ! their new positions ....... ! morph - Take two source images (source1 and source2), a set ! of warping lines (from and to) and the fraction (frac) ! between `from' and `to' to warp. Tween the lines and ! then warp the two images to the new tweened lines and ! return the result in `dest' ! ! A full morph is usually a series of images merging from one picture ! to another. To achieve this set source1 as the original picture ! (frac=0.0), source2 as the destination picture (frac=1.0) and create ! the intermediate frames using frac=0.1,0.2, ....,0.9 (depends on ! the number of frames required). ! Module Warp_code use Morph_Types use Tweens contains subroutine Morph(source1, source2, dest, from, to, frac) type(line) :: from(:), to(:) type(line),allocatable :: interim(:) type(pixel) :: source1(:,:),source2(:,:),dest(:,:) type(pixel),allocatable:: tmp1(:,:), tmp2(:,:) allocate(interim(size(from))) interim = tween_lines(from,to,frac) allocate(tmp1(size(source1,1),size(source1,2))) allocate(tmp2(size(source1,1),size(source1,2))) call warp(source1,tmp1,from,interim) call warp(source2,tmp2,to,interim) dest = tween_pixmap(tmp1,tmp2,frac) deallocate(interim) deallocate(tmp1) deallocate(tmp2) end subroutine Morph subroutine warp(source,dest,from,to) type(line) :: from(:), to(:) type(pixel):: source(:,:), dest(:,:) type(point) :: pix,tmp do i = 1, size(source,1) do j = 1, size(source,2) tmp%x = i ; tmp%y = j call sumlines(from,to,pix,tmp) pix%x = min(max(pix%x,1),size(dest,1)) pix%y = min(max(pix%y,1),size(dest,2)) dest(i,j) = source(pix%x,pix%y) enddo enddo end subroutine warp ! ! ! subroutine sumlines(from,to,source,dest) type(line) :: from(:), to(:) type(point) :: source, dest real :: ws ! weightsum real :: dsx,dsy ! deltasumx, deltasumy real :: distance real :: weight ws = 0.0 ; dsx=0.0 ; dsy=0.0 source=dest do i = 1, size(from) distance = getsourceloc(source,from(i),dest,to(i)) weight = 1.0/(0.0001+distance) ! inverse square weighting dsx = dsx + real(source%x-dest%x ) * weight dsy = dsy + real(source%y-dest%y ) * weight ws = ws + weight enddo source%x = 0.5 + dest%x + (dsx / ws) source%y = 0.5 + dest%y + (dsy / ws) end subroutine sumlines ! ! Work out which SOURCE pixel relates to the given WARPed pixel for ! this pair of orig/warp lines ! function getsourceloc(orig, origline, warp, warpline) result(distance) type(point) :: orig, warp type(line) :: origline, warpline real :: distance, fraction, fdist real :: dx, dy Integer :: wdx, wdy, wls ! warpline-delta-x .... warpline-squared real :: wl Integer :: odx, ody, ols ! warpline-delta-x .... warpline-squared real :: ol wdx = warpline%end%x-warpline%start%x wdy = warpline%end%y-warpline%start%y wls = wdx**2 + wdy**2 ; wl = sqrt(real(wls)) odx = origline%end%x-origline%start%x ody = origline%end%y-origline%start%y ols = odx**2 + ody**2 ; ol = sqrt(real(ols)) dx = warp%x - warpline%start%x dy = warp%y - warpline%start%y fraction = (dx * ( wdx) + dy * wdy) / wls fdist = (dx * (-wdy) + dy * wdx) / wl if(fraction < 0) then distance = sqrt(real(dx**2 + dy**2)) else if ( fraction > 1) then dx = warp%x - warpline%end%x dy = warp%y - warpline%end%y distance=sqrt(real(dx**2+dy**2)) else distance=abs(fdist) endif orig%x = origline%start%x + fraction*odx - fdist*ody/ol orig%y = origline%start%y + fraction*ody + fdist*odx/ol end function getsourceloc end module Warp_code !=========================================================== Program TEST use morph_types use tweens use warp_code type(pixel),allocatable :: from(:,:), to(:,:), from2(:,:) type(line), allocatable :: fl(:), tl(:) character*132 :: title='#', fmt ! Skip initial comment, get title do while (title(1:1)=='#') read(*,'(A)',err=99,end=99)title enddo ! Get problem dimensions and problem and print it read(*,*,err=99,end=99)N,M allocate(from(n,m)) allocate(from2(n,m)) allocate(to(n,m)) write(fmt,'(''('',i2,''i5)'')')2*m print *,trim(title),'(',n,',',m,')' do j = 1,M read(*,*,err=99,end=99) (from(i,j)%rgb%r,i=1,n) do i=1,n from(i,j)%rgb%b=0 from(i,j)%rgb%g=0 from2(i,j)%rgb%r=0 from2(i,j)%rgb%g=0 from2(i,j)%rgb%b=from(i,j)%rgb%r+1000 enddo enddo do j = M,1,-1 write(*,trim(fmt)) (from(i,j)%rgb%r,i=1,n),(from2(i,j)%rgb%b,i=1,n) enddo ! ! For each test ! ! do do i =1,n do j=1,m to(i,j)%rgb%r=0 to(i,j)%rgb%g=0 to(i,j)%rgb%b=0 enddo enddo read(*,'(A)',err=99,end=99)title write(*,'(A)')trim(title) read(*,*,err=99,end=99) L allocate(tl(l)) allocate(fl(l)) do i = 1, L read(*,*,err=99,end=99)fl(i)%start%x,fl(i)%start%y, & fl(i)%end%x,fl(i)%end%y, & tl(i)%start%x,tl(i)%start%y, & tl(i)%end%x,tl(i)%end%y enddo ! ! Produce 11 warped frames as a Morphing of FROM to FROM2 ! do ifrac = 1,11 write(*,'(f6.3)') real((ifrac-1)/10.0) call Morph(from,from2,to,fl,tl,real((ifrac-1)/10.0)) do j =m,1,-1 write(*,trim(fmt)) (to(i,j)%rgb%r,i=1,n), (to(i,j)%rgb%b,i=1,n) enddo enddo deallocate(fl) deallocate(tl) enddo ! ! End, clean up ! 99 continue deallocate(from) deallocate(to) end program TEST #---------------------------------------------------------- # # Test DATA ..... cut this lot to a file # # Test data file contains .... # - comment lines, starting with `#' # - title # - problem size # - problem data # # Then a number of test Morphs, each consisting of # + Title (e.g. Rotate (90):) # + Number of lines (e.g. 1) # + For each line: original start x, start y, end x and end y and # final start x, start y, end x and end y values. # (e.g. 1 6 11 6 6 1 6 11 ..... the line starting (1,6)(11,6) is # warped to (6,1)(6,11) # Input Data: 11 11 1 12 23 34 45 56 67 78 89 100 111 2 13 24 35 46 57 68 79 90 101 112 3 14 25 36 47 58 69 80 91 102 113 4 15 26 37 48 59 70 81 92 103 114 5 16 27 38 49 60 71 82 93 104 115 6 17 28 39 50 61 72 83 94 105 116 7 18 29 40 51 62 73 84 95 106 117 8 19 30 41 52 63 74 85 96 107 118 9 20 31 42 53 64 75 86 97 108 119 10 21 32 43 54 65 76 87 98 109 120 11 22 33 44 55 66 77 88 99 110 121 Rotate (90): 1 1 6 11 6 6 1 6 11 Rotate (180): 1 1 6 11 6 11 6 1 6 Warp: 3 1 1 2 1 1 1 2 1 1 6 3 6 2 6 10 6 1 11 2 11 1 11 2 11 Flip (vert): 2 1 1 1 11 1 11 1 1 11 1 11 11 11 11 11 1 Flip (horiz): 2 1 1 11 1 11 1 1 1 1 11 11 11 11 11 1 11 Squeeze: 3 1 1 11 1 1 1 11 1 1 6 11 6 1 3 11 3 1 11 11 11 1 11 11 11 Squeeze 2: 3 1 1 1 11 1 1 1 11 6 1 6 11 3 1 3 11 11 1 11 11 11 1 11 11 Robert M J Iles o_o bob@nag.co.uk Manager, Software Environments Division =( )= http://www.nag.co.uk/ The Numerical Algorithms Group Limited U NAG Ltd Wilkinson House, Jordan Hill Fax: +44 864 311205 Oxford, UK, OX2 8DR Tel: +44 865 511245