aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Data update

Browse source
This commit is contained in:
Ingy döt Net 2024-03-06 22:25:12 -08:00
parent ed705008a8
commit 0df55f9f24
2196 changed files with 32999 additions and 3075 deletions
Download patch file Download diff file Expand all files Collapse all files

65
Task/Knapsack-problem-0-1/Fortran/knapsack-problem-0-1-1.f Normal file
View file

@ -0,0 +1,65 @@
Program Knapsack01
! Translation of Pascal version on Rosetta Code.
implicit none
integer, parameter :: NUM_ITEMS = 22
integer, parameter :: MAX_WEIGHT = 400
type :: TItem
character(len=20) :: Name
integer :: Weight, Value
end type TItem
type(TItem), dimension(0:NUM_ITEMS-1) :: ITEMS
integer, dimension(0:NUM_ITEMS, 0:MAX_WEIGHT) :: D
integer :: I, W, V, MaxWeight
! Init Arrays
d = 0
ITEMS = [ TItem('compass', 13, 35), &
TItem('water', 153, 200), &
TItem('sandwich', 50, 160), &
TItem('glucose', 15, 60), &
TItem('tin', 68, 45), &
TItem('banana', 27, 60), &
TItem('apple', 39, 40), &
TItem('cheese', 23, 30), &
TItem('beer', 52, 10), &
TItem('suntan cream', 11, 70), &
TItem('camera', 32, 30), &
TItem('T-shirt', 24, 15), &
TItem('trousers', 48, 10), &
TItem('umbrella', 73, 40), &
TItem('waterproof trousers', 43, 70), &
TItem('waterproof overclothes', 42, 75), &
TItem('note-case', 22, 80), &
TItem('sunglasses', 7, 20), &
TItem('towel', 18, 12), &
TItem('map', 9, 150), &
TItem('socks', 4, 50), &
TItem('book', 30, 10) ]
!
do I = 0, NUM_ITEMS-1
do W = 0, MAX_WEIGHT
if (ITEMS(I)%Weight > W) then
D(I+1, W) = D(I, W)
else
D(I+1, W) = max(D(I, W), D(I, W - ITEMS(I)%Weight) + ITEMS(I)%Value)
end if
end do
end do
W = MAX_WEIGHT
V = D(NUM_ITEMS, W)
MaxWeight = 0
!
write(*, "(/,'bagged:')")
do I = NUM_ITEMS-1, 0, -1 !Pete
if (D(I+1, W) == V) then
if((D(I, (W - ITEMS(I)%Weight)) == V - ITEMS(I)%Value)) then
write(*, "(' ', A,t25,i0,t35,i0)", advance='yes') ITEMS(I)%Name,ITEMS(I)%weight,ITEMS(I)%value
MaxWeight = MaxWeight + ITEMS(I)%Weight
W = W - ITEMS(I)%Weight
V = V - ITEMS(I)%Value
end if
end if
end do
!
write(*, "('value = ', I0)") D(NUM_ITEMS, MAX_WEIGHT)
write(*, "('weight = ', I0)") MaxWeight
end program Knapsack01

507
Task/Knapsack-problem-0-1/Fortran/knapsack-problem-0-1-2.f Normal file
View file

@ -0,0 +1,507 @@
module ksack2
!
! THIS SUBROUTINE SOLVES THE 0-1 SINGLE KNAPSACK PROBLEM
!
! MAXIMIZE Z = P(1)*X(1) + ... + P(N)*X(N)
!
! SUBJECT TO: W(1)*X(1) + ... + W(N)*X(N) .LE. C ,
! X(J) = 0 OR 1 FOR J=1,...,N.
!
! THE PROGRAM IS INCLUDED IN THE VOLUME
! S. MARTELLO, P. TOTH, "KNAPSACK PROBLEMS: ALGORITHMS
! AND COMPUTER IMPLEMENTATIONS", JOHN WILEY, 1990
! (https://dl.acm.org/doi/book/10.5555/98124)
! AND IMPLEMENTS THE BRANCH-AND-BOUND ALGORITHM DESCRIBED IN
! SECTION 2.5.2 .
! THE PROGRAM DERIVES FROM AN EARLIER CODE PRESENTED IN
! S. MARTELLO, P. TOTH, "ALGORITHM FOR THE SOLUTION OF THE 0-1 SINGLE
! KNAPSACK PROBLEM", COMPUTING, 1978.
! The orignal program was written in Fortran 77 and was an amazing tangle of GOTO statements.
! I have reworked the code in such a manner as to eliminate the GOTO statements and bring it
! to Fortran 2018 LANGUAGE compliance though the code logic remains somewhat untractable.
!
! The routine requires a large parameter string which includes 4 dummy arrays for it's calculations.
! As well, it offers an option to check the input data for correctness.
! Rather than modify the original algorithm, I wrote a simple wrapper called "start_knapsack" that
! allocates those arrays as well as defaulting the input parameter check to "on", hiding them from the user.
! Having said that, the algorithm works very well and is very fast. I've included it in this
! Rosetta Code listing because it scales well and can be used with a large dataset.
! Which a potential user may desire.
! Peter.kelly@acm.org (28-December-2023)
!
! THE INPUT PROBLEM MUST SATISFY THE CONDITIONS
!
! 1) 2 .LE. N .LE. JDIM - 1 ;
! 2) P(J), W(J), C POSITIVE INTEGERS;
! 3) MAX (W(J)) .LE. C ;
! 4) W(1) + ... + W(N) .GT. C ;
! 5) P(J)/W(J) .GE. P(J+1)/W(J+1) FOR J=1,...,N-1. <-- Note well. They need to be sorted in the greatest ratio of (p(j)/w(j)) down to the smallest one
!
! MT1 CALLS 1 PROCEDURE: CHMT1.
!
! MT1 NEEDS 8 ARRAYS ( P , W , X , XX , MIN , PSIGN , WSIGN
! AND ZSIGN ) OF LENGTH AT LEAST N + 1 .
!
! MEANING OF THE INPUT PARAMETERS:
! N = NUMBER OF ITEMS;
! P(J) = PROFIT OF ITEM J (J=1,...,N);
! W(J) = WEIGHT OF ITEM J (J=1,...,N);
! C = CAPACITY OF THE KNAPSACK;
! JDIM = DIMENSION OF THE 8 ARRAYS;
! JCK = 1 IF CHECK ON THE INPUT DATA IS DESIRED,
! = 0 OTHERWISE.
!
! MEANING OF THE OUTPUT PARAMETERS:
! Z = VALUE OF THE OPTIMAL SOLUTION IF Z .GT. 0 ,
! = ERROR IN THE INPUT DATA (WHEN JCK=1) IF Z .LT. 0 : CONDI-
! TION - Z IS VIOLATED;
! X(J) = 1 IF ITEM J IS IN THE OPTIMAL SOLUTION,
! = 0 OTHERWISE.
!
! ARRAYS XX, MIN, PSIGN, WSIGN AND ZSIGN ARE DUMMY.
!
! ALL THE PARAMETERS ARE INTEGER. ON RETURN OF MT1 ALL THE INPUT
! PARAMETERS ARE UNCHANGED.
!
implicit none
contains
subroutine mt1(n , p , w , c , z , x , jdim , jck , xx , min , psign , wsign , zsign)
implicit none
integer :: jdim
integer :: n
integer , intent(inout) , dimension(jdim) :: p
integer , intent(inout) , dimension(jdim) :: w
integer :: c
integer , intent(inout) :: z
integer , intent(out) , dimension(jdim) :: x
integer , intent(in) :: jck
integer , intent(inout) , dimension(jdim) :: xx
integer , intent(inout) , dimension(jdim) :: min
integer , intent(inout) , dimension(jdim) :: psign
integer , intent(inout) , dimension(jdim) :: wsign
integer , intent(inout) , dimension(jdim) :: zsign
!
real :: a
real :: b
integer :: ch
integer :: chs
integer :: diff
integer :: ii
integer :: ii1
integer :: in
integer :: ip
integer :: iu
integer :: j
integer :: j1
integer :: jj
integer :: jtemp
integer :: kk
integer :: lim
integer :: lim1
integer :: ll
integer :: lold
integer :: mink
integer :: n1
integer :: nn
integer :: profit
integer :: r
integer :: t
integer :: next_code_block
!*Code
next_code_block = 1
dispatch_loop: do
select case(next_code_block)
case(1)
z = 0
if( jck==1 )call chmt1(n , p , w , c , z , jdim)
if( z<0 )return
! INITIALIZE.
ch = c
ip = 0
chs = ch
first_loop: do ll = 1 , n
if( w(ll)>chs )exit first_loop
ip = ip + p(ll)
chs = chs - w(ll)
end do first_loop
ll = ll - 1
if( chs==0 )then
z = ip
x(1:ll) = 1
nn = ll + 1
x(nn:n) = 0
return
else
p(n + 1) = 0
w(n + 1) = ch + 1
lim = ip + chs*p(ll + 2)/w(ll + 2)
a = w(ll + 1) - chs
b = ip + p(ll + 1)
lim1 = b - a*float(p(ll))/float(w(ll))
if( lim1>lim )lim = lim1
mink = ch + 1
min(n) = mink
do j = 2 , n
kk = n + 2 - j
if( w(kk)<mink )mink = w(kk)
min(kk - 1) = mink
end do
xx(1:n) = 0
z = 0
profit = 0
lold = n
ii = 1
next_code_block = 4
cycle dispatch_loop
end if
case(2)
! TRY TO INSERT THE II-TH ITEM INTO THE CURRENT SOLUTION.
do while ( w(ii)>ch )
ii1 = ii + 1
if( z>=ch*p(ii1)/w(ii1) + profit )then
next_code_block = 5
cycle dispatch_loop
end if
ii = ii1
end do
! BUILD A NEW CURRENT SOLUTION.
ip = psign(ii)
chs = ch - wsign(ii)
in = zsign(ii)
ll = in
do while ( ll<=n )
if( w(ll)>chs )then
iu = chs*p(ll)/w(ll)
ll = ll - 1
if( iu==0 )then
next_code_block = 3
cycle dispatch_loop
end if
if( z>=profit + ip + iu )then
next_code_block = 5
cycle dispatch_loop
end if
next_code_block = 4
cycle dispatch_loop
else
ip = ip + p(ll)
chs = chs - w(ll)
end if
end do
ll = n
next_code_block = 3
case(3)
if( z>=ip + profit )then
next_code_block = 5
cycle dispatch_loop
end if
z = ip + profit
nn = ii - 1
x(1:nn) = xx(1:nn)
x(ii:ll) = 1
if( ll/=n )then
nn = ll + 1
x(nn:n) = 0
end if
if( z/=lim )then
next_code_block = 5
cycle dispatch_loop
end if
return
case(4)
! SAVE THE CURRENT SOLUTION.
wsign(ii) = ch - chs
psign(ii) = ip
zsign(ii) = ll + 1
xx(ii) = 1
nn = ll - 1
if( nn>=ii )then
do j = ii , nn
wsign(j + 1) = wsign(j) - w(j)
psign(j + 1) = psign(j) - p(j)
zsign(j + 1) = ll + 1
xx(j + 1) = 1
end do
end if
j1 = ll + 1
wsign(j1:lold) = 0
psign(j) = 0
zsign(j1:lold) = [(jtemp, jtemp = j1,lold)]
lold = ll
ch = chs
profit = profit + ip
if( ll<(n - 2) )then
ii = ll + 2
if( ch>=min(ii - 1) )then
next_code_block = 2
cycle dispatch_loop
end if
else if( ll==(n - 2) )then
if( ch>=w(n) )then
ch = ch - w(n)
profit = profit + p(n)
xx(n) = 1
end if
ii = n - 1
else
ii = n
end if
! SAVE THE CURRENT OPTIMAL SOLUTION.
if( z<profit )then
z = profit
x(1:n) = xx(1:n)
if( z==lim )return
end if
if( xx(n)/=0 )then
xx(n) = 0
ch = ch + w(n)
profit = profit - p(n)
end if
next_code_block = 5
case(5)
outer_loop: do ! BACKTRACK.
nn = ii - 1
if( nn==0 )return
middle_loop: do j = 1 , nn
kk = ii - j
if( xx(kk)==1 )then
r = ch
ch = ch + w(kk)
profit = profit - p(kk)
xx(kk) = 0
if( r<min(kk) )then
nn = kk + 1
ii = kk
! TRY TO SUBSTITUTE THE NN-TH ITEM FOR THE KK-TH.
inner_loop: do while ( z<profit + ch*p(nn)/w(nn) )
diff = w(nn) - w(kk)
if( diff<0 )then
t = r - diff
if( t>=min(nn) )then
if( z>=profit + p(nn) + t*p(nn + 1)/w(nn + 1) )exit inner_loop
ch = ch - w(nn)
profit = profit + p(nn)
xx(nn) = 1
ii = nn + 1
wsign(nn) = w(nn)
psign(nn) = p(nn)
zsign(nn) = ii
n1 = nn + 1
wsign(n1:lold) = 0
psign(n1:lold) = 0
zsign(n1:lold) = [(jtemp, jtemp = n1,lold)]
lold = nn
next_code_block = 2
cycle dispatch_loop
end if
else if( diff/=0 )then
if( diff<=r )then
if( z<profit + p(nn) )then
z = profit + p(nn)
x(1:kk) = xx(1:kk)
jj = kk + 1
x(jj:n) = 0
x(nn) = 1
if( z==lim )return
r = r - diff
kk = nn
nn = nn + 1
cycle inner_loop
end if
end if
end if
nn = nn + 1
end do inner_loop
cycle outer_loop
else
ii = kk + 1
next_code_block = 2
cycle dispatch_loop
end if
end if
end do middle_loop
exit outer_loop
end do outer_loop
exit dispatch_loop
end select
end do dispatch_loop
end subroutine mt1
!
subroutine chmt1(n , p , w , c , z , jdim)
integer , intent(in) :: jdim
integer , intent(in) :: n
integer , intent(in) , dimension(jdim) :: p
integer , intent(in) , dimension(jdim) :: w
integer , intent(in) :: c
integer , intent(out) :: z
!
! Local variable declarations
!
integer :: j
integer :: jsw
real :: r
real :: rr
!
! CHECK THE INPUT DATA.
!
if(( n<2) .or. (n>jdim - 1) )then
z = -1
return
else if( c>0 )then
jsw = 0
rr = float(p(1))/float(w(1))
do j = 1 , n
r = rr
if(( p(j)<=0 ).or.( w(j)<=0 ))then
z = -2
return
end if
jsw = jsw + w(j)
if( w(j)<=c )then
rr = float(p(j))/float(w(j))
if( rr>r )then
z = -5
return
end if
else
z = -3
return
end if
end do
if( jsw>c )return
z = -4
return
end if
z = -2
return
end subroutine chmt1
subroutine start_knapsack(n , profit , weight , capacity , result_val , members)
!
! Dummy argument declarations
!
integer , intent(in) :: n
integer , intent(inout) , dimension(n) :: profit
integer , intent(inout) , dimension(n) :: weight
integer , intent(in) :: capacity
integer , intent(inout) :: result_val
integer , intent(inout) , dimension(n) :: members
!
! Local variable declarations
integer :: bigger
integer :: jck
integer , allocatable , dimension(:) :: mini
integer , allocatable , dimension(:) :: psign
integer , allocatable , dimension(:) :: wsign
integer , allocatable , dimension(:) :: xx
integer , allocatable , dimension(:) :: zsign
!
!Designed to invoke MT1
!MT1 NEEDS 8 ARRAYS ( P , W , X , XX , MIN , PSIGN , WSIGN
! AND ZSIGN ) OF LENGTH AT LEAST N + 1 .
! MEANING OF THE INPUT PARAMETERS:
! N = NUMBER OF ITEMS;
! P(J) = PROFIT OF ITEM J (J=1,...,N);
! W(J) = WEIGHT OF ITEM J (J=1,...,N);
! C = CAPACITY OF THE KNAPSACK;
! JDIM = DIMENSION OF THE 8 ARRAYS;
! JCK = 1 IF CHECK ON THE INPUT DATA IS DESIRED,
! = 0 OTHERWISE.
!
! MEANING OF THE OUTPUT PARAMETERS:
! Z = VALUE OF THE OPTIMAL SOLUTION IF Z .GT. 0 ,
! = ERROR IN THE INPUT DATA (WHEN JCK=1) IF Z .LT. 0 : CONDI-
! TION - Z IS VIOLATED;
! X(J) = 1 IF ITEM J IS IN THE OPTIMAL SOLUTION,
! = 0 OTHERWISE.
!
! ARRAYS XX, MIN, PSIGN, WSIGN AND ZSIGN ARE DUMMY.
!
! ALL THE PARAMETERS ARE INTEGER. ON RETURN OF MT1 ALL THE INPUT
! PARAMETERS ARE UNCHANGED.
!
jck = 1 !Set parameter checking on
bigger = n + 100
!
! Allocate the dummy arrays
allocate(xx(bigger))
allocate(mini(bigger))
allocate(psign(bigger))
allocate(wsign(bigger))
allocate(zsign(bigger))
call mt1(n , profit , weight , capacity , result_val , members , bigger , jck , xx , mini , psign , wsign , zsign)
deallocate(xx)
deallocate(mini)
deallocate(psign)
deallocate(wsign)
deallocate(zsign)
end subroutine start_knapsack
end module ksack2
!
program serious_knapsack
use ksack2
integer, parameter :: list_size=22
integer:: p(list_size) ! The weights
integer::n,profit(list_size),capacity,result_val,members(size(p)),valuez,t1,t2,j
character(len=25) :: names(list_size),tempnam
real :: ratio(list_size),rats
logical :: swapped
capacity =400
members = 0
result_val = 0
n = list_size
p(1:list_size) = (/13,153, 50,15,68,27,39,23,52,11,32,24,48,73,43,42,22,07,18,009,04,30/)
profit(1:list_size) =(/35,200,160,60,45,60,40,30,10,70,30,15,10,40,70,75,80,20,12,150,50,10/)
names(1:22) =[character(len=25) ::'compass','water','sandwich','glucose','tin','banana','apple', 'cheese', &
'beer','suntan cream','camera','T-shirt','trousers','umbrella','waterproof trousers', 'waterproof overclothes', &
'note-case','sunglasses','towel','map','socks', 'book']
ratio(1:22) = float(profit(1:22))/float(p(1:22))
! The mt1 algorithm wants the data sorted downwards(large-->small) by the ration of profit/weight
! So, I implemented a quick bubble sort to order the lists
swapped = .true.
do while (swapped)
swapped = .false.
do j = 1,21
if(ratio(j).lt.ratio(j+1))then ! Swaps everywhere
swapped = .true.
t1 = p(j+1) ! Swap the weights
p(j+1) = p(j)
p(j) = t1
t2 = profit(j+1) !Swap the profits
profit(j+1) = profit(j)
profit(j) = t2
tempnam = names(j+1) ! Swap the names around
names(j+1) = names(j)
names(j) = tempnam
rats = ratio(j+1) ! Swap the ratios
ratio(j+1) = ratio(j)
ratio(j) = rats
endif
end do
end do
!
call system_clock(count=xx)
call startup(n,profit(1:22),p(1:22),capacity,result_val,members)
call system_clock(count=yy)
print*,'Total of the sack = ',result_val
capacity = 0
valuez = 0
n = 0
do i = 1,size(members)
if(members(i) /=0)then
capacity = capacity +p(i)
valuez = profit(i) + valuez
n = n+1
print*, names(i),p(i),profit(i)
endif
end do
print*,'Filled capacity = ',capacity,'Value = ',valuez!,'No items = ',n,sum(profit(1:22)),sum(p(1:22))
print*
print*,'First knapsack time = ',(yy-xx),'Milliseconds'
stop 'All done'
end program serious_knapsack